Back to home page

sPhenix code displayed by LXR
 
 

    

File indexing completed on 2025-08-03 08:21:29 

0001 C*********************************************************************
0002 C*********************************************************************
0003 C*                                                                  **
0004 C*                                                 September 2013   **
0005 C*                                                                  **
0006 C*                       The Lund Monte Carlo                       **
0007 C*                                                                  **
0008 C*                        PYTHIA version 6.4                        **
0009 C*                                                                  **
0010 C*                        Torbjorn Sjostrand                        **
0011 C*                 Department of Theoretical Physics                **
0012 C*                         Lund University                          **
0013 C*               Solvegatan 14A, S-223 62 Lund, Sweden              **
0014 C*                    E-mail torbjorn@thep.lu.se                    **
0015 C*                                                                  **
0016 C*                  SUSY and Technicolor parts by                   **
0017 C*                         Stephen Mrenna                           **
0018 C*                       Computing Division                         ** 
0019 C*            Generators and Detector Simulation Group              **
0020 C*              Fermi National Accelerator Laboratory               **
0021 C*                 MS 234, Batavia, IL  60510, USA                  **
0022 C*                   phone + 1 - 630 - 840 - 2556                   **
0023 C*                      E-mail mrenna@fnal.gov                      **
0024 C*                                                                  **
0025 C*         New multiple interactions and more SUSY parts by         **
0026 C*                          Peter Skands                            **
0027 C*               CERN/PH, CH-1211 Geneva, Switzerland               **
0028 C*                    phone +41 - 22 - 767 2447                     **
0029 C*                   E-mail peter.skands@cern.ch                    **
0030 C*                                                                  **
0031 C*         Several parts are written by Hans-Uno Bengtsson          **
0032 C*          PYSHOW is written together with Mats Bengtsson          **
0033 C*               PYMAEL is written by Emanuel Norrbin               **
0034 C*     advanced popcorn baryon production written by Patrik Eden    **
0035 C*    code for virtual photons mainly written by Christer Friberg   **
0036 C*    code for low-mass strings mainly written by Emanuel Norrbin   **
0037 C*        Bose-Einstein code mainly written by Leif Lonnblad        **
0038 C*      CTEQ  parton distributions are by the CTEQ collaboration    **
0039 C*      GRV 94 parton distributions are by Glueck, Reya and Vogt    **
0040 C*   SaS photon parton distributions together with Gerhard Schuler  **
0041 C*     g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt     **
0042 C*         MSSM Higgs mass calculation code by M. Carena,           **
0043 C*           J.R. Espinosa, M. Quiros and C.E.M. Wagner             **
0044 C*  UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
0045 C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **
0046 C*        NRQCD/colour octet production of onium by S. Wolf         **
0047 C*                                                                  **
0048 C*   The latest program version and documentation is found on WWW   **
0049 C*            http://www.thep.lu.se/~torbjorn/Pythia.html           **
0050 C*                                                                  **
0051 C*              Copyright Torbjorn Sjostrand, Lund 2010             **
0052 C*                                                                  **
0053 C*********************************************************************
0054 C*********************************************************************
0055 C                                                                    *
0056 C  List of subprograms in order of appearance, with main purpose     *
0057 C  (S = subroutine, F = function, B = block data)                    *
0058 C                                                                    *
0059 C  B   PYDATA   to contain all default values                        *
0060 C  S   PYCKBD   to check that BLOCK DATA has been correctly loaded   *
0061 C  S   PYTEST   to test the proper functioning of the package        *
0062 C  S   PYHEPC   to convert between /PYJETS/ and /HEPEVT/ records     *
0063 C                                                                    *
0064 C  S   PYINIT   to administer the initialization procedure           *
0065 C  S   PYEVNT   to administer the generation of an event             *
0066 C  S   PYEVNW   ditto, for new multiple interactions scenario        *
0067 C  S   PYSTAT   to print cross-section and other information         *
0068 C  S   PYUPEV   to administer the generation of an LHA hard process  *
0069 C  S   PYUPIN   to provide initialization needed for LHA input       *
0070 C  S   PYLHEF   to produce a Les Houches Event File from run         *
0071 C  S   PYINRE   to initialize treatment of resonances                *
0072 C  S   PYINBM   to read in beam, target and frame choices            *
0073 C  S   PYINKI   to initialize kinematics of incoming particles       *
0074 C  S   PYINPR   to set up the selection of included processes        *
0075 C  S   PYXTOT   to give total, elastic and diffractive cross-sect.   *
0076 C  S   PYMAXI   to find differential cross-section maxima            *
0077 C  S   PYPILE   to select multiplicity of pileup events              *
0078 C  S   PYSAVE   to save alternatives for gamma-p and gamma-gamma     *
0079 C  S   PYGAGA   to handle lepton -> lepton + gamma branchings        *
0080 C  S   PYRAND   to select subprocess and kinematics for event        *
0081 C  S   PYSCAT   to set up kinematics and colour flow of event        *
0082 C  S   PYEVOL   handler for pT-ordered ISR and multiple interactions *
0083 C  S   PYSSPA   to simulate initial state spacelike showers          *
0084 C  S   PYPTIS   to do pT-ordered initial state spacelike showers     *
0085 C  S   PYMEMX   auxiliary to PYSSPA/PYPTIS for ME correction maximum *
0086 C  S   PYMEWT   auxiliary to PYSSPA/.. for matrix element correction *
0087 C  S   PYPTMI   to do pT-ordered multiple interactions               *
0088 C  F   PYFCMP   to give companion quark x*f distribution             *
0089 C  F   PYPCMP   to calculate momentum integral for companion quarks  *
0090 C  S   PYUPRE   to rearranges contents of the HEPEUP commonblock     *
0091 C  S   PYADSH   to administrate sequential final-state showers       *
0092 C  S   PYVETO   to allow the generation of an event to be aborted    *
0093 C  S   PYRESD   to perform resonance decays                          *
0094 C  S   PYMULT   to generate multiple interactions - old scheme       *
0095 C  S   PYREMN   to add on target remnants - old scheme               *
0096 C  S   PYMIGN   to generate multiple interactions - new scheme       *
0097 C  S   PYMIHK   to connect colours in mult. int. - new scheme        *
0098 C  S   PYCTTR   to translate PYTHIA colour information to LHA1 tags  *
0099 C  S   PYMIHG   to collapse two pairs of LHA1 colour tags.           *
0100 C  S   PYMIRM   to add on target remnants in mult. int.- new scheme  *
0101 C  S   PYFSCR   to perform final state colour reconnections - -"-    *
0102 C  S   PYDIFF   to set up kinematics for diffractive events          *
0103 C  S   PYDISG   to set up kinematics, remnant and showers for DIS    *
0104 C  S   PYDOCU   to compute cross-sections and handle documentation   *
0105 C  S   PYFRAM   to perform boosts between different frames           *
0106 C  S   PYWIDT   to calculate full and partial widths of resonances   *
0107 C  S   PYOFSH   to calculate partial width into off-shell channels   *
0108 C  S   PYRECO   to handle colour reconnection in W+W- events         *
0109 C  S   PYKLIM   to calculate borders of allowed kinematical region   *
0110 C  S   PYKMAP   to construct value of kinematical variable           *
0111 C  S   PYSIGH   to calculate differential cross-sections             *
0112 C  S   PYSGQC   auxiliary to PYSIGH for QCD processes                *
0113 C  S   PYSGHF   auxiliary to PYSIGH for heavy flavour processes      *
0114 C  S   PYSGWZ   auxiliary to PYSIGH for W and Z processes            *
0115 C  S   PYSGHG   auxiliary to PYSIGH for Higgs processes              *
0116 C  S   PYSGSU   auxiliary to PYSIGH for supersymmetry processes      *
0117 C  S   PYSGTC   auxiliary to PYSIGH for technicolor processes        *
0118 C  S   PYSGEX   auxiliary to PYSIGH for various exotic processes     *
0119 C  S   PYPDFU   to evaluate parton distributions                     *
0120 C  S   PYPDFL   to evaluate parton distributions at low x and Q^2    *
0121 C  S   PYPDEL   to evaluate electron parton distributions            *
0122 C  S   PYPDGA   to evaluate photon parton distributions (generic)    *
0123 C  S   PYGGAM   to evaluate photon parton distributions (SaS sets)   *
0124 C  S   PYGVMD   to evaluate VMD part of photon parton distributions  *
0125 C  S   PYGANO   to evaluate anomalous part of photon PDFs            *
0126 C  S   PYGBEH   to evaluate Bethe-Heitler part of photon PDFs        *
0127 C  S   PYGDIR   to evaluate direct contribution to photon PDFs       *
0128 C  S   PYPDPI   to evaluate pion parton distributions                *
0129 C  S   PYPDPR   to evaluate proton parton distributions              *
0130 C  F   PYCTEQ   to evaluate the CTEQ 3 proton parton distributions   *
0131 C  S   PYGRVL   to evaluate the GRV 94L proton parton distributions  *
0132 C  S   PYGRVM   to evaluate the GRV 94M proton parton distributions  *
0133 C  S   PYGRVD   to evaluate the GRV 94D proton parton distributions  *
0134 C  F   PYGRVV   auxiliary to the PYGRV* routines                     *
0135 C  F   PYGRVW   auxiliary to the PYGRV* routines                     *
0136 C  F   PYGRVS   auxiliary to the PYGRV* routines                     *
0137 C  F   PYCT5L   to evaluate the CTEQ 5L proton parton distributions  *
0138 C  F   PYCT5M   to evaluate the CTEQ 5M1 proton parton distributions *
0139 C  S   PYPDPO   to evaluate old proton parton distributions          *
0140 C  F   PYHFTH   to evaluate threshold factor for heavy flavour       *
0141 C  S   PYSPLI   to find flavours left in hadron when one removed     *
0142 C  F   PYGAMM   to evaluate ordinary Gamma function Gamma(x)         *
0143 C  S   PYWAUX   to evaluate auxiliary functions W1(s) and W2(s)      *
0144 C  S   PYI3AU   to evaluate auxiliary function I3(s,t,u,v)           *
0145 C  F   PYSPEN   to evaluate Spence (dilogarithm) function Sp(x)      *
0146 C  S   PYQQBH   to evaluate matrix element for g + g -> Q + Qbar + H *
0147 C  S   PYSTBH   to evaluate matrix element for t + b + H processes   *
0148 C  S   PYTBHB   auxiliary to PYSTBH                                  *
0149 C  S   PYTBHG   auxiliary to PYSTBH                                  *
0150 C  S   PYTBHQ   auxiliary to PYSTBH                                  *
0151 C  F   PYTBHS   auxiliary to PYSTBH                                  *
0152 C                                                                    *
0153 C  S   PYMSIN   to initialize the supersymmetry simulation           *
0154 C  S   PYSLHA   to interface to SUSY spectrum and decay calculators  *
0155 C  S   PYAPPS   to determine MSSM parameters from SUGRA input        *
0156 C  S   PYSUGI   to determine MSSM parameters using ISASUSY           *
0157 C  S   PYFEYN   to determine MSSM Higgs parameters using FEYNHIGGS   *
0158 C  F   PYRNMQ   to determine running squark masses                   *
0159 C  S   PYTHRG   to calculate sfermion third-gen. mass eigenstates    *
0160 C  S   PYINOM   to calculate neutralino/chargino mass eigenstates    *
0161 C  F   PYRNM3   to determine running M3, gluino mass                 *
0162 C  S   PYEIG4   to calculate eigenvalues and -vectors in 4*4 matrix  *
0163 C  S   PYHGGM   to determine Higgs mass spectrum                     *
0164 C  S   PYSUBH   to determine Higgs masses in the MSSM                *
0165 C  S   PYPOLE   to determine Higgs masses in the MSSM                *
0166 C  S   PYRGHM   auxiliary to PYPOLE                                  *
0167 C  S   PYGFXX   auxiliary to PYRGHM                                  *
0168 C  F   PYFINT   auxiliary to PYPOLE                                  *
0169 C  F   PYFISB   auxiliary to PYFINT                                  *
0170 C  S   PYSFDC   to calculate sfermion decay partial widths           *
0171 C  S   PYGLUI   to calculate gluino decay partial widths             *
0172 C  S   PYTBBN   to calculate 3-body decay of gluino to neutralino    *
0173 C  S   PYTBBC   to calculate 3-body decay of gluino to chargino      *
0174 C  S   PYNJDC   to calculate neutralino decay partial widths         *
0175 C  S   PYCJDC   to calculate chargino decay partial widths           *
0176 C  F   PYXXZ6   auxiliary for ino 3-body decays                      *
0177 C  F   PYXXGA   auxiliary for ino -> ino + gamma decay               *
0178 C  F   PYX2XG   auxiliary for ino -> ino + gauge boson decay         *
0179 C  F   PYX2XH   auxiliary for ino -> ino + Higgs decay               *
0180 C  S   PYHEXT   to calculate non-SM Higgs decay partial widths       *
0181 C  F   PYH2XX   auxiliary for H -> ino + ino decay                   *
0182 C  F   PYGAUS   to perform Gaussian integration                      *
0183 C  F   PYGAU2   copy of PYGAUS to allow two-dimensional integration  *
0184 C  F   PYSIMP   to perform Simpson integration                       *
0185 C  F   PYLAMF   to evaluate the lambda kinematics function           *
0186 C  S   PYTBDY   to perform 3-body decay of gauginos                  *
0187 C  S   PYTECM   to calculate techni_rho/omega masses                 *
0188 C  S   PYXDIN   to initialize Universal Extra Dimensions             *
0189 C  S   PYUEDC   to compute UED mass radiative corrections            *
0190 C  S   PYXUED   to compute UED cross sections                        *
0191 C  S   PYGRAM   to generate UED G* (excited graviton) mass spectrum  *
0192 C  F   PYGRAW   to compute UED partial widths to G*                  *
0193 C  F   PYWDKK   to compute UED differential partial widths to G*     *
0194 C  S   PYEICG   to calculate eigenvalues of a 4*4 complex matrix     *
0195 C  S   PYCMQR   auxiliary to PYEICG                                  *
0196 C  S   PYCMQ2   auxiliary to PYEICG                                  *
0197 C  S   PYCDIV   auxiliary to PYCMQR                                  *
0198 C  S   PYCSRT   auxiliary to PYCMQR                                  *
0199 C  S   PYTHAG   auxiliary to PYCMQR                                  *
0200 C  S   PYCBAL   auxiliary to PYEICG                                  *
0201 C  S   PYCBA2   auxiliary to PYEICG                                  *
0202 C  S   PYCRTH   auxiliary to PYEICG                                  *
0203 C  S   PYLDCM   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
0204 C  S   PYBKSB   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
0205 C  S   PYWIDX   to calculate decay widths from within PYWIDT         *
0206 C  S   PYRVSF   to calculate R-violating sfermion decay widths       *
0207 C  S   PYRVNE   to calculate R-violating neutralino decay widths     *
0208 C  S   PYRVCH   to calculate R-violating chargino decay widths       *
0209 C  S   PYRVGL   to calculate R-violating gluino decay widths         *
0210 C  F   PYRVSB   auxiliary to PYRVSF                                  *
0211 C  S   PYRVGW   to calculate R-Violating 3-body widths               *
0212 C  F   PYRVI1   auxiliary to PYRVGW, to do PS integration for res.   *
0213 C  F   PYRVI2   auxiliary to PYRVGW, to do PS integration for LR-int.*
0214 C  F   PYRVI3   auxiliary to PYRVGW, to do PS X integral for int.    *
0215 C  F   PYRVG1   auxiliary to PYRVI1, general matrix element, res.    *
0216 C  F   PYRVG2   auxiliary to PYRVI2, general matrix element, LR-int. *
0217 C  F   PYRVG3   auxiliary to PYRVI3, to do PS Y integral for int.    *
0218 C  F   PYRVG4   auxiliary to PYRVG3, general matrix element, int.    *
0219 C  F   PYRVR    auxiliary to PYRVG1, Breit-Wigner                    *
0220 C  F   PYRVS    auxiliary to PYRVG2 & PYRVG4                         *
0221 C                                                                    *
0222 C  S   PY1ENT   to fill one entry (= parton or particle)             *
0223 C  S   PY2ENT   to fill two entries                                  *
0224 C  S   PY3ENT   to fill three entries                                *
0225 C  S   PY4ENT   to fill four entries                                 *
0226 C  S   PY2FRM   to interface to generic two-fermion generator        *
0227 C  S   PY4FRM   to interface to generic four-fermion generator       *
0228 C  S   PY6FRM   to interface to generic six-fermion generator        *
0229 C  S   PY4JET   to generate a shower from a given 4-parton config    *
0230 C  S   PY4JTW   to evaluate the weight od a shower history for above *
0231 C  S   PY4JTS   to set up the parton configuration for above         *
0232 C  S   PYJOIN   to connect entries with colour flow information      *
0233 C  S   PYGIVE   to fill (or query) commonblock variables             *
0234 C  S   PYONOF   to allow easy control of particle decay modes        *
0235 C  S   PYTUNE   to select a predefined 'tune' for min-bias and UE    *
0236 C  S   PYEXEC   to administrate fragmentation and decay chain        *
0237 C  S   PYPREP   to rearrange showered partons along strings          *
0238 C  S   PYSTRF   to do string fragmentation of jet system             *
0239 C  S   PYJURF   to find boost to string junction rest frame          *
0240 C  S   PYINDF   to do independent fragmentation of one or many jets  *
0241 C  S   PYDECY   to do the decay of a particle                        *
0242 C  S   PYDCYK   to select parton and hadron flavours in decays       *
0243 C  S   PYKFDI   to select parton and hadron flavours in fragm        *
0244 C  S   PYNMES   to select number of popcorn mesons                   *
0245 C  S   PYKFIN   to calculate falvour prod. ratios from input params. *
0246 C  S   PYPTDI   to select transverse momenta in fragm                *
0247 C  S   PYZDIS   to select longitudinal scaling variable in fragm     *
0248 C  S   PYSHOW   to do m-ordered timelike parton shower evolution     *
0249 C  S   PYPTFS   to do pT-ordered timelike parton shower evolution    *
0250 C  F   PYMAEL   auxiliary to PYSHOW & PYPTFS: gluon emission ME's    *
0251 C  S   PYBOEI   to include Bose-Einstein effects (crudely)           *
0252 C  S   PYBESQ   auxiliary to PYBOEI                                  *
0253 C  F   PYMASS   to give the mass of a particle or parton             *
0254 C  F   PYMRUN   to give the running MSbar mass of a quark            *
0255 C  S   PYNAME   to give the name of a particle or parton             *
0256 C  F   PYCHGE   to give three times the electric charge              *
0257 C  F   PYCOMP   to compress standard KF flavour code to internal KC  *
0258 C  S   PYERRM   to write error messages and abort faulty run         *
0259 C  F   PYALEM   to give the alpha_electromagnetic value              *
0260 C  F   PYALPS   to give the alpha_strong value                       *
0261 C  F   PYANGL   to give the angle from known x and y components      *
0262 C  F   PYR      to provide a random number generator                 *
0263 C  S   PYRGET   to save the state of the random number generator     *
0264 C  S   PYRSET   to set the state of the random number generator      *
0265 C  S   PYROBO   to rotate and/or boost an event                      *
0266 C  S   PYEDIT   to remove unwanted entries from record               *
0267 C  S   PYLIST   to list event record or particle data                *
0268 C  S   PYLOGO   to write a logo                                      *
0269 C  S   PYUPDA   to update particle data                              *
0270 C  F   PYK      to provide integer-valued event information          *
0271 C  F   PYP      to provide real-valued event information             *
0272 C  S   PYSPHE   to perform sphericity analysis                       *
0273 C  S   PYTHRU   to perform thrust analysis                           *
0274 C  S   PYCLUS   to perform three-dimensional cluster analysis        *
0275 C  S   PYCELL   to perform cluster analysis in (eta, phi, E_T)       *
0276 C  S   PYJMAS   to give high and low jet mass of event               *
0277 C  S   PYFOWO   to give Fox-Wolfram moments                          *
0278 C  S   PYTABU   to analyze events, with tabular output               *
0279 C                                                                    *
0280 C  S   PYEEVT   to administrate the generation of an e+e- event      *
0281 C  S   PYXTEE   to give the total cross-section at given CM energy   *
0282 C  S   PYRADK   to generate initial state photon radiation           *
0283 C  S   PYXKFL   to select flavour of primary qqbar pair              *
0284 C  S   PYXJET   to select (matrix element) jet multiplicity          *
0285 C  S   PYX3JT   to select kinematics of three-jet event              *
0286 C  S   PYX4JT   to select kinematics of four-jet event               *
0287 C  S   PYXDIF   to select angular orientation of event               *
0288 C  S   PYONIA   to perform generation of onium decay to gluons       *
0289 C                                                                    *
0290 C  S   PYBOOK   to book a histogram                                  *
0291 C  S   PYFILL   to fill an entry in a histogram                      *
0292 C  S   PYFACT   to multiply histogram contents by a factor           *
0293 C  S   PYOPER   to perform operations between histograms             *
0294 C  S   PYHIST   to print and reset all histograms                    *
0295 C  S   PYPLOT   to print a single histogram                          *
0296 C  S   PYNULL   to reset contents of a single histogram              *
0297 C  S   PYDUMP   to dump histogram contents onto a file               *
0298 C                                                                    *
0299 C  S   PYSTOP   routine to handle Fortran STOP condition             *
0300 C                                                                    *
0301 C  S   PYKCUT   dummy routine for user kinematical cuts              *
0302 C  S   PYEVWT   dummy routine for weighting events                   *
0303 C  S   UPINIT   dummy routine to initialize user processes           *
0304 C  S   UPEVNT   dummy routine to generate a user process event       *
0305 C  S   UPVETO   dummy routine to abort event at parton level         *
0306 C  S   PDFSET   dummy routine to be removed when using PDFLIB        *
0307 C  S   STRUCTM  dummy routine to be removed when using PDFLIB        *
0308 C  S   STRUCTP  dummy routine to be removed when using PDFLIB        *
0309 C  S   SUGRA    dummy routine to be removed when linking with ISAJET *
0310 C  F   VISAJE   dummy functn. to be removed when linking with ISAJET *
0311 C  S   SSMSSM   dummy routine to be removed when linking with ISAJET *
0312 C  S   FHSETFLAGS  dummy routine          -"-              FEYNHIGGS *
0313 C  S   FHSETPARA   dummy routine          -"-              FEYNHIGGS *
0314 C  S   FHHIGGSCORR dummy routine          -"-              FEYNHIGGS *
0315 C  S   PYTAUD   dummy routine for interface to tau decay libraries   *
0316 C  S   PYTIME   dummy routine for giving date and time               *
0317 C                                                                    *
0318 C*********************************************************************
0319  
0320 C...PYDATA
0321 C...Default values for switches and parameters,
0322 C...and particle, decay and process data.
0323  
0324       BLOCK DATA PYDATA
0325  
0326 C...Double precision and integer declarations.
0327       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
0328       IMPLICIT INTEGER(I-N)
0329       INTEGER PYK,PYCHGE,PYCOMP
0330 C...Commonblocks.
0331       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0332       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
0333       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0334       COMMON/PYDAT4/CHAF(500,2)
0335       CHARACTER CHAF*16
0336       COMMON/PYDATR/MRPY(6),RRPY(100)
0337       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
0338       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
0339       COMMON/PYINT1/MINT(400),VINT(400)
0340       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
0341       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
0342       COMMON/PYINT4/MWID(500),WIDS(500,5)
0343       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
0344       COMMON/PYINT6/PROC(0:500)
0345       CHARACTER PROC*28
0346       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
0347       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
0348       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
0349      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
0350       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
0351       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
0352       COMMON/PYPUED/IUED(0:99),RUED(0:99)
0353       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
0354       COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
0355      &     AU(3,3),AD(3,3),AE(3,3)
0356       COMMON/PYLH3C/CPRO(2),CVER(2)
0357       CHARACTER CPRO*12,CVER*12
0358       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
0359      &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
0360      &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
0361      &/PYBINS/,/PYLH3P/,/PYLH3C/
0362  
0363 C...PYDAT1, containing status codes and most parameters.
0364       DATA MSTU/
0365      &   0,    0,    0, 4000,10000,  500, 8000,    0,    0,    2,
0366      1   6,    0,    1,    0,    0,    1,    0,    0,    0,    0,
0367      2   2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
0368      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
0369      4   2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
0370      5  25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
0371      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
0372      7  30*0,
0373      1   1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
0374      2   1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
0375      &  80*0/
0376       DATA (PARU(I),I=1,100)/
0377      &  3.141592653589793D0, 6.283185307179586D0,
0378      &  0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0,  4*0D0,
0379      1  0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
0380      2  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
0381      3  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
0382      4  2.0D0,  1.0D0, 0.25D0,  2.5D0, 0.05D0,
0383      4  0D0,   0D0, 0.0001D0, 0D0,   0D0,
0384      5  2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
0385      6  40*0D0/
0386       DATA (PARU(I),I=101,200)/
0387      &  0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
0388      &  0D0, 0D0, 0D0, 0D0,  0D0,
0389      1  0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0,  0D0, 0D0, 0D0,
0390      2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
0391      2 -1.0D0,  1.0D0,  1.0D0,  1.0D0,  0D0,
0392      3  1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
0393      4  5.0D0, 1.0D0, 1.0D0,  0D0, 1.0D0, 1.0D0,  0D0, 0D0, 0D0, 0D0,
0394      5  1.0D0,   0D0,   0D0,   0D0,   0D0,   0D0, 0D0, 0D0, 0D0, 0D0,
0395      6  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
0396      7  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
0397      8  1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
0398      9  0D0,  0D0,  0D0,  0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0/
0399       DATA MSTJ/
0400      &  1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
0401      1  4,    2,    0,    1,    0,    2,    2,   20,    0,    0,
0402      2  2,    1,    1,    2,    1,    2,    2,    0,    0,    0,
0403      3  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
0404      4  2,    2,    4,    2,    5,    3,    3,    0,    0,    3,
0405      5  0,    3,    0,    2,    0,    0,    1,    0,    0,    0,
0406      6  40*0,
0407      &  5,    2,    7,    5,    1,    1,    0,    2,    0,    2,
0408      1  0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
0409      2  80*0/
0410       DATA PARJ/
0411      &  0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
0412      &  0.50D0, 0.50D0,   0.6D0,   1.2D0,   0.6D0,
0413      1  0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
0414      2  0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
0415      3  0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
0416      4  0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
0417      5  0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
0418      5  0D0, 0D0, 0D0, 1.0D0, 0D0,
0419      6  4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
0420      7  10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
0421      8  0.29D0, 1.0D0, 1.0D0,  0D0,  10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
0422      9  0.02D0, 1.0D0, 0.2D0,  0D0,  0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
0423      &  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
0424      1  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
0425      2  1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
0426      2  2.0D0,  1.0D0, 0.25D0,0.002D0,   0D0,
0427      3  0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0,  0.2D0,   0D0,
0428      4  10*0D0,
0429      5  10*0D0,
0430      6  10*0D0,
0431      7  0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
0432      8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
0433      8  1.0D0,  1.0D0, -0.693D0, -1.0D0, 0.387D0,
0434      9  1.0D0, -0.08D0, -1.0D0,   1.0D0, 1.0D0,
0435      9  5*0D0/
0436  
0437 C...PYDAT2, with particle data and flavour treatment parameters.
0438       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,   
0439      &-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,  
0440      &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,  
0441      &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,   
0442      &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,    
0443      &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,  
0444      &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,  
0445      &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,  
0446      &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,  
0447      &7*0,3,
0448 C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
0449      &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2, 
0450      &3*-3,0,-3,0,-3,0,-3,
0451      &3*0,3, 
0452      &25*0/
0453       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,   
0454      &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,   
0455      &-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, 
0456      &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
0457      &83*0,12*1,9*0,2,3*0,25*0/
0458       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,   
0459      &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, 
0460      &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, 
0461      &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,
0462      &81*0,21*1,3*0,1,25*0/
0463       DATA (KCHG(I,4),I=   1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 
0464      &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,   
0465      &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,   
0466      &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,   
0467      &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,   
0468      &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,  
0469      &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,  
0470      &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,  
0471      &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,   
0472      &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314, 
0473      &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214, 
0474      &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412, 
0475      &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142, 
0476      &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322, 
0477      &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442, 
0478      &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,     
0479      &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,      
0480      &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,      
0481      &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,      
0482      &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/      
0483       DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,      
0484      &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,   
0485      &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,  
0486      &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,  
0487      &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,  
0488      &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,  
0489      &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,  
0490      &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,  
0491      &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,  
0492      &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,  
0493      &3000115,3000215,
0494      &81*0,
0495 C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
0496      &6100001,6100002,6100003,6100004,6100005,6100006, 
0497      &5100001,5100002,5100003,5100004,5100005,5100006, 
0498      &6100011,6100013,6100015,
0499      &5100012,5100011,5100014,5100013,5100016,5100015, 
0500      &5100021,5100022,5100023,5100024,
0501      &25*0/ 
0502       DATA (PMAS(I,1),I=   1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,    
0503      &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,      
0504      &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,     
0505      &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,  
0506      &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0, 
0507      &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,   
0508      &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,       
0509      &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,    
0510      &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,       
0511      &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,   
0512      &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,     
0513      &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,  
0514      &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,       
0515      &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,  
0516      &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,   
0517      &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,       
0518      &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0, 
0519      &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,          
0520      &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,   
0521      &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/  
0522       DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,   
0523      &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,    
0524      &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,        
0525      &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,      
0526      &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,           
0527      &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,       
0528      &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0, 
0529      &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,     
0530      &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0, 
0531      &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,     
0532      &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,        
0533      &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,      
0534      &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,        
0535      &3*9.5D0,2*250D0,
0536      &81*0,
0537 C...UED
0538      &586.,588.,586.,588.,586.,586.,6*598.,
0539      &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
0540       DATA (PMAS(I,2),I=   1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,    
0541      &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,    
0542      &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,   
0543      &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,        
0544      &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0, 
0545      &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,   
0546      &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0, 
0547      &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,     
0548      &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,       
0549      &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,   
0550      &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,     
0551      &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,   
0552      &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,     
0553      &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,       
0554      &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,   
0555      &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,  
0556      &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,   
0557      &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/                       
0558       DATA (PMAS(I,3),I=   1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,  
0559      &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,           
0560      &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,    
0561      &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,    
0562      &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0, 
0563      &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,  
0564      &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0, 
0565      &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0, 
0566      &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,        
0567      &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,    
0568      &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,  
0569      &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,       
0570      &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0, 
0571      &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,    
0572      &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,          
0573      &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,   
0574      &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,  
0575      &8.80013D0,13*0D0,2.54987D0,2.84456D0,
0576      &81*0,
0577 C...UED
0578      &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
0579       DATA (PMAS(I,4),I=   1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0, 
0580      &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,      
0581      &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,  
0582      &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,    
0583      &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,    
0584      &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,  
0585      &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,    
0586      &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/        
0587 
0588       DATA PARF/
0589      &  0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0,  0D0,  0D0,  0D0, 0D0,
0590      1  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
0591      2  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
0592      3  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
0593      4  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
0594      5  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
0595      6  0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
0596      7  0D0,  0D0,  1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
0597      8  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
0598      9  0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0,  4*0D0,
0599      & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
0600      1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
0601      2 0.2D0, 0.1D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
0602      3 60*0D0,
0603      4 0.2D0,  0.5D0,  8*0D0,
0604      5 1800*0D0/
0605       DATA ((VCKM(I,J),J=1,4),I=1,4)/
0606      &  0.95113D0,  0.04884D0,  0.00003D0,  0.00000D0,
0607      &  0.04884D0,  0.94940D0,  0.00176D0,  0.00000D0,
0608      &  0.00003D0,  0.00176D0,  0.99821D0,  0.00000D0,
0609      &  0.00000D0,  0.00000D0,  0.00000D0,  1.00000D0/
0610  
0611 C...PYDAT3, with particle decay parameters and data.
0612       DATA (MDCY(I,1),I=   1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,   
0613      &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, 
0614      &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,  
0615      &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,
0616      &81*0,
0617 C...UED
0618      &5*1,0,5*1,0,13*1,25*0/
0619       DATA (MDCY(I,2),I=   1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,  
0620      &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,  
0621      &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,    
0622      &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,  
0623      &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,  
0624      &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,   
0625      &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077, 
0626      &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,   
0627      &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,     
0628      &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,   
0629      &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,   
0630      &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,    
0631      &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471, 
0632      &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506, 
0633      &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543, 
0634      &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592, 
0635      &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162, 
0636      &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,  
0637      &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,  
0638      &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/ 
0639       DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,   
0640      &4214,4215,4216,4296,4322,
0641      &81*0,
0642 C...UED
0643      %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
0644      &5031,5032,5033,
0645      &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
0646      &25*0/
0647       DATA (MDCY(I,3),I=   1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,    
0648      &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, 
0649      &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,  
0650      &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,  
0651      &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, 
0652      &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, 
0653      &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,   
0654      &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,   
0655      &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,    
0656      &3*22,15,12,2*7,7*0,6*1,26,30,
0657      &81*0,
0658 C...UED
0659      &6*2,6*3,9*1,24,1,18,6,25*0/                                 
0660       DATA (MDME(I,1),I=   1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,  
0661      &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,  
0662      &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,  
0663      &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,   
0664      &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,    
0665      &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,     
0666      &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, 
0667      &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,  
0668      &5*-1,3*1,-1,
0669      &649*0,
0670 C...UED
0671      &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
0672      &1,24*1,2912*0/
0673       DATA (MDME(I,2),I=   1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102, 
0674      &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,     
0675      &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,   
0676      &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,     
0677      &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,    
0678      &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,  
0679      &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,     
0680      &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,    
0681      &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,   
0682      &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,    
0683      &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, 
0684      &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, 
0685      &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,   
0686      &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,   
0687      &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,     
0688      &16*32,
0689 C...UED
0690      &653*0,30*0,9*0,12*0,37*0,2912*0/
0691       DATA (BRAT(I)  ,I=   1, 348)/43*0D0,0.00003D0,0.001765D0,         
0692      &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,  
0693      &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,     
0694      &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,        
0695      &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,      
0696      &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,  
0697      &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,        
0698      &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,    
0699      &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,      
0700      &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,     
0701      &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0, 
0702      &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,         
0703      &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,    
0704      &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0, 
0705      &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,    
0706      &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,     
0707      &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,   
0708      &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,          
0709      &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,         
0710      &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/ 
0711       DATA (BRAT(I)  ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0, 
0712      &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,         
0713      &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0, 
0714      &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,     
0715      &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,        
0716      &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,     
0717      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,       
0718      &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0, 
0719      &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,  
0720      &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,          
0721      &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,    
0722      &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,      
0723      &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,    
0724      &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,   
0725      &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,     
0726      &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,  
0727      &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,     
0728      &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,       
0729      &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,        
0730      &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/     
0731       DATA (BRAT(I)  ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,  
0732      &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0, 
0733      &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,   
0734      &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,     
0735      &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,      
0736      &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0, 
0737      &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,        
0738      &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0, 
0739      &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,       
0740      &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,  
0741      &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,     
0742      &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,   
0743      &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,      
0744      &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,     
0745      &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,    
0746      &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,     
0747      &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,       
0748      &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,  
0749      &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0, 
0750      &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/      
0751       DATA (BRAT(I)  ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,    
0752      &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0, 
0753      &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,     
0754      &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,        
0755      &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,   
0756      &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,       
0757      &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,    
0758      &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,  
0759      &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,       
0760      &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,          
0761      &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,         
0762      &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,      
0763      &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,    
0764      &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,   
0765      &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,         
0766      &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,       
0767      &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, 
0768      &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,    
0769      &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,    
0770      &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/        
0771       DATA (BRAT(I)  ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,     
0772      &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,   
0773      &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,   
0774      &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,   
0775      &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,        
0776      &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0, 
0777      &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,   
0778      &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,  
0779      &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,      
0780      &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,     
0781      &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,       
0782      &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,          
0783      &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,   
0784      &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,     
0785      &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,          
0786      &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,         
0787      &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,       
0788      &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,  
0789      &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,    
0790      &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/        
0791       DATA (BRAT(I)  ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,     
0792      &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,  
0793      &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,    
0794      &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,   
0795      &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,      
0796      &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,      
0797      &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,      
0798      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,      
0799      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,       
0800      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,  
0801      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0802      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0803      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0804      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0805      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0806      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0807      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0808      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0809      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
0810      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/      
0811       DATA (BRAT(I)  ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,   
0812      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0813      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0814      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0815      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0816      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0817      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0818      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
0819      &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,     
0820      &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,    
0821      &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,      
0822      &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,  
0823      &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,  
0824      &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,      
0825      &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,      
0826      &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,       
0827      &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0, 
0828      &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,   
0829      &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,       
0830      &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/       
0831       DATA (BRAT(I)  ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,      
0832      &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,      
0833      &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,   
0834      &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,      
0835      &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,     
0836      &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,      
0837      &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,           
0838      &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,  
0839      &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,       
0840      &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,           
0841      &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0, 
0842      &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,     
0843      &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,    
0844      &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0, 
0845      &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0, 
0846      &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,           
0847      &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,     
0848      &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0, 
0849      &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0, 
0850      &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/     
0851       DATA (BRAT(I)  ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,    
0852      &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,           
0853      &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,           
0854      &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,     
0855      &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0, 
0856      &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,           
0857      &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,   
0858      &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,          
0859      &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,          
0860      &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0, 
0861      &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,           
0862      &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,           
0863      &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,           
0864      &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,       
0865      &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,       
0866      &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,           
0867      &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,     
0868      &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,    
0869      &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,         
0870      &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/           
0871       DATA (BRAT(I)  ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,    
0872      &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,     
0873      &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0, 
0874      &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0, 
0875      &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,   
0876      &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,      
0877      &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,          
0878      &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0, 
0879      &2*0.011947D0,0.011946D0,0D0,
0880      &649*0.D0,
0881 C....UED
0882      &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
0883      &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, 
0884      &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
0885      &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
0886      &9*1.D0,              
0887      &24*0.0416667,        
0888      &1.,                  
0889      &3*0.D0,6*0.08333D0, 
0890      &3*0.D0,6*0.08333D0,
0891      &6*0.166667D0,        
0892      &2912*0.D0/
0893       DATA (KFDP(I,1),I=   1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,  
0894      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,    
0895      &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22, 
0896      &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,   
0897      &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25, 
0898      &-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,  
0899      &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,  
0900      &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,        
0901      &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,        
0902      &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,        
0903      &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,         
0904      &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,        
0905      &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,        
0906      &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,        
0907      &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,         
0908      &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,  
0909      &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,   
0910      &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,  
0911      &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,      
0912      &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/       
0913       DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,    
0914      &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,        
0915      &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,        
0916      &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,         
0917      &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,        
0918      &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,        
0919      &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,  
0920      &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,   
0921      &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,       
0922      &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,        
0923      &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,        
0924      &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,         
0925      &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,        
0926      &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,        
0927      &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,  
0928      &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035, 
0929      &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,       
0930      &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2, 
0931      &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,  
0932      &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/ 
0933       DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,   
0934      &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,   
0935      &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,    
0936      &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,  
0937      &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,   
0938      &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,   
0939      &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,  
0940      &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,      
0941      &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421, 
0942      &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311, 
0943      &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,   
0944      &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311, 
0945      &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,      
0946      &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,  
0947      &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,   
0948      &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,    
0949      &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,     
0950      &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,    
0951      &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,       
0952      &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/  
0953       DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,    
0954      &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,  
0955      &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,   
0956      &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,  
0957      &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,    
0958      &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13, 
0959      &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,   
0960      &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,     
0961      &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,     
0962      &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,   
0963      &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,   
0964      &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,    
0965      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,   
0966      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16, 
0967      &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,     
0968      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,     
0969      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,  
0970      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,   
0971      &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,  
0972      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/     
0973       DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, 
0974      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,   
0975      &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,  
0976      &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,     
0977      &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313, 
0978      &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,     
0979      &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513, 
0980      &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113, 
0981      &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,   
0982      &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443, 
0983      &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555, 
0984      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,        
0985      &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,  
0986      &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,   
0987      &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,  
0988      &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,        
0989      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,        
0990      &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,  
0991      &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,   
0992      &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/  
0993       DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,     
0994      &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,      
0995      &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,  
0996      &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,   
0997      &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,  
0998      &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,  
0999      &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,      
1000      &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012, 
1001      &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,        
1002      &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,  
1003      &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,     
1004      &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,  
1005      &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,        
1006      &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,  
1007      &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,     
1008      &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,  
1009      &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,        
1010      &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,  
1011      &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,      
1012      &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/       
1013       DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,   
1014      &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,      
1015      &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,  
1016      &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,     
1017      &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11, 
1018      &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,   
1019      &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,   
1020      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,   
1021      &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,   
1022      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,   
1023      &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,  
1024      &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12, 
1025      &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,   
1026      &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,   
1027      &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,   
1028      &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,   
1029      &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,   
1030      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,   
1031      &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,   
1032      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/ 
1033       DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,     
1034      &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,    
1035      &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,       
1036      &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,      
1037      &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,       
1038      &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,      
1039      &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,       
1040      &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,      
1041      &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,       
1042      &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,      
1043      &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,       
1044      &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,      
1045      &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,   
1046      &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,   
1047      &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
1048      &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,   
1049      &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
1050      &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,   
1051      &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
1052      &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/   
1053       DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,  
1054      &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,      
1055      &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,        
1056      &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,      
1057      &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,      
1058      &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,       
1059      &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,   
1060      &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,  
1061      &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,   
1062      &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12, 
1063      &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14, 
1064      &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, 
1065      &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16, 
1066      &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, 
1067      &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,    
1068      &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,      
1069      &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,       
1070      &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,      
1071      &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,       
1072      &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/      
1073       DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,   
1074      &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,       
1075      &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,      
1076      &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,       
1077      &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,      
1078      &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,       
1079      &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,      
1080      &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,   
1081      &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,   
1082      &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
1083      &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,   
1084      &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
1085      &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,   
1086      &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
1087      &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,   
1088      &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039, 
1089      &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,        
1090      &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,      
1091      &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,       
1092      &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/      
1093       DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,   
1094      &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,       
1095      &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,      
1096      &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,       
1097      &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,      
1098      &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,       
1099      &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,      
1100      &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12, 
1101      &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,   
1102      &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,   
1103      &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
1104      &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,   
1105      &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
1106      &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,   
1107      &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
1108      &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,  
1109      &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,     
1110      &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,  
1111      &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,        
1112      &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/      
1113       DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,   
1114      &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,      
1115      &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, 
1116      &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,    
1117      &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,   
1118      &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,     
1119      &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, 
1120      &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14, 
1121      &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16, 
1122      &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16, 
1123      &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1, 
1124      &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,  
1125      &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,        
1126      &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,  
1127      &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,   
1128      &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,        
1129      &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,        
1130      &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,      
1131      &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,  
1132      &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/   
1133       DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,     
1134      &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,        
1135      &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,       
1136      &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,       
1137      &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12, 
1138      &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,    
1139      &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,        
1140      &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,   
1141      &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,     
1142      &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,   
1143      &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,   
1144      &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,   
1145      &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,   
1146      &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,        
1147      &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,  
1148      &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,  
1149      &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, 
1150      &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,   
1151      &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18, 
1152      &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1153      &9*15/     
1154       DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1155      &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,   
1156      &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,      
1157      &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,   
1158      &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23, 
1159      &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15, 
1160      &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,   
1161      &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,    
1162      &-11,-13,-15,-17,
1163      &649*0,
1164 C...UED
1165      &5100023,5100022,5100023,5100022,5100023,5100022,
1166      &5100023,5100022,5100023,5100022,5100023,5100022, 
1167      &5100023,-5100024,5100022,5100023,5100024,5100022,
1168      &5100023,-5100024,5100022,5100023,5100024,5100022,
1169      &5100023,-5100024,5100022,5100023,5100024,5100022, 
1170      &9*5100022, 
1171      &6100001,6100002,6100003,6100004,6100005,6100006,
1172      &5100001,5100002,5100003,5100004,5100005,5100006,
1173      &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1174      &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006, 
1175      &39, 
1176      &6100011,6100013,6100015,
1177      &5100011,5100013,5100015,
1178      %5100012,5100014,5100016,
1179      &-6100011,-6100013,-6100015,
1180      &-5100011,-5100013,-5100015,
1181      %-5100012,-5100014,-5100016,
1182      &-5100011,-5100013,-5100015,
1183      &5100012,5100014,5100016,
1184      &2912*0/
1185       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, 
1186      &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,  
1187      &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, 
1188      &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,     
1189      &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,     
1190      &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211, 
1191      &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, 
1192      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,  
1193      &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,  
1194      &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,   
1195      &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,    
1196      &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,     
1197      &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,          
1198      &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,          
1199      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,          
1200      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,          
1201      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,          
1202      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, 
1203      &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8, 
1204      &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/   
1205       DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,    
1206      &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,  
1207      &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,       
1208      &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002, 
1209      &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, 
1210      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,          
1211      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,          
1212      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,          
1213      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, 
1214      &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,      
1215      &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,  
1216      &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,  
1217      &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004, 
1218      &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,          
1219      &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,          
1220      &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,          
1221      &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,          
1222      &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,        
1223      &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,       
1224      &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/ 
1225       DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,   
1226      &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211, 
1227      &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,   
1228      &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,  
1229      &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,    
1230      &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,   
1231      &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223, 
1232      &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,    
1233      &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,   
1234      &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,    
1235      &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211, 
1236      &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,    
1237      &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310, 
1238      &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111, 
1239      &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,       
1240      &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,    
1241      &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213, 
1242      &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,     
1243      &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,    
1244      &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/   
1245       DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,   
1246      &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,  
1247      &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,     
1248      &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,   
1249      &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,   
1250      &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,  
1251      &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211, 
1252      &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,   
1253      &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,    
1254      &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211, 
1255      &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,   
1256      &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,  
1257      &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,  
1258      &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,  
1259      &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,  
1260      &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,  
1261      &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,   
1262      &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,  
1263      &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, 
1264      &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/ 
1265       DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3, 
1266      &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, 
1267      &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, 
1268      &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, 
1269      &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113, 
1270      &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,   
1271      &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,   
1272      &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,   
1273      &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,  
1274      &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,   
1275      &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,    
1276      &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13, 
1277      &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,  
1278      &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,   
1279      &-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,     
1280      &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,  
1281      &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, 
1282      &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, 
1283      &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,  
1284      &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/  
1285       DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5, 
1286      &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, 
1287      &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, 
1288      &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, 
1289      &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,   
1290      &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, 
1291      &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,  
1292      &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, 
1293      &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, 
1294      &-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, 
1295      &-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, 
1296      &-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, 
1297      &-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, 
1298      &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,    
1299      &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,   
1300      &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, 
1301      &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, 
1302      &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, 
1303      &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, 
1304      &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/ 
1305       DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,  
1306      &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11, 
1307      &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,   
1308      &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5, 
1309      &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14, 
1310      &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,    
1311      &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,   
1312      &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, 
1313      &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, 
1314      &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, 
1315      &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, 
1316      &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, 
1317      &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,    
1318      &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37, 
1319      &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,   
1320      &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,     
1321      &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,  
1322      &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,   
1323      &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,   
1324      &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/  
1325       DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,  
1326      &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1, 
1327      &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,  
1328      &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, 
1329      &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,  
1330      &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3, 
1331      &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13, 
1332      &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,   
1333      &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,   
1334      &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,  
1335      &-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, 
1336      &-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, 
1337      &-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, 
1338      &-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, 
1339      &-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, 
1340      &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,  
1341      &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, 
1342      &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,    
1343      &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,   
1344      &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/  
1345       DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,  
1346      &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,    
1347      &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,   
1348      &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,  
1349      &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, 
1350      &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, 
1351      &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, 
1352      &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, 
1353      &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11, 
1354      &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,   
1355      &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,   
1356      &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,  
1357      &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,     
1358      &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,  
1359      &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3, 
1360      &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,   
1361      &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,  
1362      &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,   
1363      &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,   
1364      &-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/     
1365       DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5, 
1366      &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,   
1367      &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,   
1368      &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,  
1369      &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,  
1370      &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,  
1371      &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,  
1372      &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,     
1373      &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,  
1374      &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,  
1375      &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,  
1376      &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,  
1377      &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,   
1378      &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,   
1379      &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,   
1380      &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11, 
1381      &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,  
1382      &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,     
1383      &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,     
1384      &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/   
1385       DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,   
1386      &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,   
1387      &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,   
1388      &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17, 
1389      &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,  
1390      &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,  
1391      &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24, 
1392      &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,        
1393      &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,  
1394      &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,    
1395      &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,      
1396      &649*0,
1397 C...UED     
1398      &1,1,2,2,3,3,4,4,5,5,6,6, 
1399      &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1400      &11,13,15,12,11,14,13,16,15, 
1401      &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1402      &1,2,3,4,5,6,1,2,3,4,5,6, 
1403      &22, 
1404      &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1405      &11,13,15,11,13,15,12,14,16,
1406      &12,14,16,-11,-13,-15, 
1407      &2912*0/
1408       DATA (KFDP(I,3),I=   1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,  
1409      &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,    
1410      &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,   
1411      &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,    
1412      &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,    
1413      &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,  
1414      &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,   
1415      &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,   
1416      &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,    
1417      &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,  
1418      &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,   
1419      &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,    
1420      &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0, 
1421      &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,      
1422      &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,  
1423      &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,    
1424      &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,  
1425      &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,    
1426      &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,   
1427      &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/  
1428       DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,  
1429      &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112, 
1430      &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0, 
1431      &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,  
1432      &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,  
1433      &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,    
1434      &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,  
1435      &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,    
1436      &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,  
1437      &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,  
1438      &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1, 
1439      &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,  
1440      &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,  
1441      &-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, 
1442      &-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, 
1443      &-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, 
1444      &-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,   
1445      &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, 
1446      &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,   
1447      &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ 
1448       DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,  
1449      &-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, 
1450      &-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, 
1451      &-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,   
1452      &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,  
1453      &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, 
1454      &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, 
1455      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
1456      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,  
1457      &-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, 
1458      &-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, 
1459      &-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, 
1460      &-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,   
1461      &-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, 
1462      &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,  
1463      &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11, 
1464      &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1, 
1465      &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,   
1466      &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,   
1467      &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/   
1468       DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, 
1469      &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,  
1470      &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,   
1471      &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, 
1472      &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, 
1473      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
1474      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,  
1475      &-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, 
1476      &-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, 
1477      &-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, 
1478      &-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,   
1479      &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,   
1480      &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,    
1481      &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,  
1482      &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4, 
1483      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
1484      &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1, 
1485      &-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, 
1486      &-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, 
1487      &-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/ 
1488       DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,  
1489      &-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,   
1490      &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,   
1491      &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,    
1492      &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,    
1493      &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,  
1494      &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,   
1495      &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,   
1496      &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,   
1497      &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,   
1498      &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,  
1499      &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, 
1500      &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4, 
1501      &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4, 
1502      &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/    
1503       DATA (KFDP(I,4),I=   1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,  
1504      &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,     
1505      &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,  
1506      &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,    
1507      &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,   
1508      &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,  
1509      &-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,    
1510      &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,   
1511      &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, 
1512      &162*81,31*0,-211,111,6516*0/                                      
1513       DATA (KFDP(I,5),I=   1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,     
1514      &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,     
1515      &3*111,-211,111,7193*0/                                            
1516  
1517 C...PYDAT4, with particle names (character strings).
1518       DATA (CHAF(I,1),I=   1, 202)/'d','u','s','c','b','t','b''','t''', 
1519      &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',         
1520      &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',   
1521      &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',     
1522      &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',     
1523      &'junction',' ','system','cluster','string','indep.','CMshower',   
1524      &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',  
1525      &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',     
1526      &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi', 
1527      &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',     
1528      &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',  
1529      &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',  
1530      &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',  
1531      &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',   
1532      &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',    
1533      &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',       
1534      &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',  
1535      &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',   
1536      &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',          
1537      &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/       
1538       DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',            
1539      &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',  
1540      &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+', 
1541      &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',    
1542      &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',     
1543      &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',   
1544      &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',          
1545      &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',            
1546      &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',    
1547      &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1', 
1548      &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',   
1549      &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',  
1550      &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',      
1551      &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',       
1552      &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',       
1553      &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',         
1554      &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',          
1555      &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',  
1556      &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',         
1557      &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/      
1558       DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',      
1559      &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',        
1560      &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',     
1561      &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',         
1562      &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',         
1563      &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',        
1564      &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1565      &81*' ',
1566 C...UED    
1567      &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1568      &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1569      &'e*_S-','mu*_S-','tau*_S-',
1570      &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1571      &'g*','gamma*','Z*0','W*+',25*' '/               
1572       DATA (CHAF(I,2),I=   1, 205)/'dbar','ubar','sbar','cbar','bbar',  
1573      &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',   
1574      &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',       
1575      &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',  
1576      &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ', 
1577      &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',  
1578      &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',      
1579      &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',   
1580      &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',   
1581      &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',    
1582      &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+', 
1583      &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',        
1584      &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',         
1585      &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',     
1586      &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar', 
1587      &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',            
1588      &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',      
1589      &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',               
1590      &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',   
1591      &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/    
1592       DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',   
1593      &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',   
1594      &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',             
1595      &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',        
1596      &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',  
1597      &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',  
1598      &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',           
1599      &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',       
1600      &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+', 
1601      &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',                 
1602      &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',  
1603      &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',         
1604      &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',       
1605      &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',         
1606      &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',           
1607      &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',          
1608      &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',        
1609      &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',  
1610      &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',      
1611      &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/       
1612       DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',              
1613      &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar', 
1614      &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',            
1615      &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',     
1616      &81*' ',
1617 C...UED
1618      &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1619      &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1620      &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1621      &'nu*_eDbar','e*_Dbar+',
1622      &'nu*_muDbar','mu*_Dbar+',
1623      &'nu*_tauDbar','tau*_Dbar+',
1624      &'g*','gamma*','Z*0','W*-',25*' '/            
1625  
1626 C...PYDATR, with initial values for the random number generator.
1627       DATA MRPY/19780503,0,0,97,33,0/
1628  
1629 C...Default values for allowed processes and kinematics constraints.
1630       DATA MSEL/1/
1631       DATA MSUB/500*0/
1632       DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1633      &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,
1634      &6*1,4*0,4*1,16*0/
1635       DATA CKIN/
1636      &  2.0D0, -1.0D0,  0.0D0, -1.0D0,  1.0D0,
1637      &  1.0D0,  -10D0,   10D0,  -40D0,   40D0,
1638      1  -40D0,   40D0,  -40D0,   40D0,  -40D0,
1639      1   40D0, -1.0D0,  1.0D0, -1.0D0,  1.0D0,
1640      2  0.0D0,  1.0D0,  0.0D0,  1.0D0, -1.0D0,
1641      2  1.0D0, -1.0D0,  1.0D0,    0D0,    0D0,
1642      3  2.0D0, -1.0D0,    0D0,    0D0,  0.0D0,
1643      3 -1.0D0,  0.0D0, -1.0D0,  4.0D0, -1.0D0,
1644      4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1645      4 -1.0D0, 12.0D0, -1.0D0,    0D0,    0D0,
1646      5  0.0D0, -1.0D0,  0.0D0, -1.0D0,  0.0D0,
1647      5 -1.0D0,    0D0,    0D0,    0D0,    0D0,
1648      6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0,    0D0,
1649      6   -1D0,    0D0,   -1D0,    0D0,   -1D0,
1650      7    0D0,   -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1651      7 0.99D0,    2D0,   -1D0,    0D0,    0D0,
1652      8  120*0D0/
1653  
1654 C...Default values for main switches and parameters. Reset information.
1655       DATA (MSTP(I),I=1,100)/
1656      &  3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
1657      1  1,    0,    1,   30,    0,    1,    4,    3,    4,    3,
1658      2  1,    0,    1,    0,    0,    0,    0,    0,    0,    1,
1659      3  1,    8,    0,    1,    0,    2,    1,    5,    2,    0,
1660      4  2,    1,    3,    7,    3,    1,    1,    0,    1,    0,
1661      5  7,    1,    3,    1,    5,    1,    1,    5,    1,    7,
1662      6  2,    3,    2,    2,    1,    5,    2,    3,    0,    0,
1663      7  1,    1,    0,    0,    0,    0,    0,    0,    0,    0,
1664      8  1,    4,  100,    1,    1,    2,    4,    1,    1,    0,
1665      9  1,    3,    1,    3,    1,    0,    0,    0,    0,    0/
1666       DATA (MSTP(I),I=101,200)/
1667      &  3,    1,    0,    0,    0,    0,    0,    0,    0,    0,
1668      1  1,    1,    1,    0,    0,    0,    0,    0,    0,    0,
1669      2  0,    1,    2,    1,    1,  100,    0,    0,   10,    0,
1670      3  0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
1671      4  0,    0,    0,    0,    0,    1,    0,    0,    0,    0,
1672      5  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1673      6  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1674      7  0,    2,    0,    0,    0,    0,    0,    0,    0,    0,
1675      8  6,  428, 2013,    9,    5,    0,    0,    0,    0,    0,
1676      9  0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1677       DATA (PARP(I),I=1,100)/
1678      &  0.25D0,  10D0, 8*0D0,
1679      1  0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1680      2  10*0D0,
1681      3  1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1682      4  0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1683      5  10*0D0,
1684      6  0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1685      7  4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1686      8  1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1687      8  0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1688      9  2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1689       DATA (PARP(I),I=101,200)/
1690      &  0.5D0, 0.28D0,  1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1691      1  2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1692      2  1.0D0,  0.4D0, 8*0D0,
1693      3  0.01D0, 9*0D0,
1694      4  1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0, 
1695      4  9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1696      5  0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1697      6  2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1698      7  0D0,   0D0,   0D0,  1.0D0, 6*0D0,
1699      8  0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1700      8  0.3D0, 0.64D0,
1701      9  0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1702       DATA MSTI/200*0/
1703       DATA PARI/200*0D0/
1704       DATA MINT/400*0/
1705       DATA VINT/400*0D0/
1706  
1707 C...Constants for the generation of the various processes.
1708       DATA (ISET(I),I=1,100)/
1709      &  1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,    2,
1710      1  2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1711      2 -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1712      3  2,    2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,
1713      4 -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
1714      5 -1,   -1,    2,    2,   -1,   -1,   -1,    2,   -1,   -1,
1715      6 -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,    2,    2,
1716      7  4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,    2,
1717      8  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1718      9  0,    0,    0,    0,    0,    9,   -2,   -2,    8,   -2/
1719       DATA (ISET(I),I=101,200)/
1720      & -1,    1,    1,    1,    1,    2,    2,    2,   -2,    2,
1721      1  2,    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,
1722      2  5,    5,    5,    5,   -2,   -2,   -2,   -2,   -2,   -2,
1723      3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1724      4  1,    1,    1,    1,    1,    1,    1,    1,    1,   -2,
1725      5  1,    1,    1,   -2,   -2,    1,    1,    1,   -2,   -2,
1726      6  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1727      7  2,    2,    5,    5,   -2,    2,    2,    5,    5,   -2,
1728      8  5,    5,    2,    2,    2,    5,    5,    2,    2,    2,
1729      9  1,    1,    1,    2,    2,   -2,   -2,   -2,   -2,   -2/
1730       DATA (ISET(I),I=201,300)/
1731      &  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1732      1  2,    2,    2,    2,   -2,    2,    2,    2,    2,    2,
1733      2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1734      3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1735      4  2,    2,    2,    2,   -1,    2,    2,    2,    2,    2,
1736      5  2,    2,    2,    2,   -1,    2,   -1,    2,    2,   -2,
1737      6  2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,   -1,
1738      7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1739      8  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1740      9  2,    2,    2,    2,    2,    2,    2,    2,    2,    2/
1741       DATA (ISET(I),I=301,500)/
1742      &  2, 9*-2, 9*2, 21*-2,
1743      4  1,    1,    2,    2,    2,    2,    2,    2,    2,    2,
1744      5  5,    5,    1,    1,   -1,   -1,   -1,   -1,   -1,   -1,
1745      6  2,    2,    2,    2,    2,    2,    2,    2,   -1,    2,
1746      7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1747      8  2,    2,    2,    2,    2,    2,    2,    2,   -2,   -2,
1748      9  1,    1,    2,    2,    2, 5*-2,
1749      &  5,    5, 18*-2,
1750      2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1751      3  2,    2,    2,    2,    2,    2,    2,    2,    2, 21*-2,
1752      6  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1753      7  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1754      8  2,    2,  18*-2/
1755       DATA ((KFPR(I,J),J=1,2),I=1,50)/
1756      &  23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
1757      &  24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
1758      1   0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
1759      1  21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
1760      2  22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
1761      2  24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
1762      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1763      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1764      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1765      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
1766       DATA ((KFPR(I,J),J=1,2),I=51,100)/
1767      5   0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
1768      5   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1769      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1770      6   0,    0,    0,    0,   21,   21,   24,   24,   23,   24,
1771      7  23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
1772      7  23,   23,   24,   24,   24,   25,   25,   25,    0,  211,
1773      8   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1774      8 443,   21,10441,   21,20443,   21,  445,   21,    0,    0,
1775      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1776      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1777       DATA ((KFPR(I,J),J=1,2),I=101,150)/
1778      &  23,    0,   25,    0,   25,    0,10441,    0,  445,    0,
1779      & 443,   22,  443,   21,  443,   22,    0,    0,   22,   25,
1780      1  21,   25,    0,   25,   21,   25,   22,   22,   21,   22,
1781      1  22,   23,   23,   23,   24,   24,    0,    0,    0,    0,
1782      2  25,    6,   25,    6,   25,    0,   25,    0,    0,    0,
1783      2   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1784      3   0,   21,    0,   21,    0,   22,    0,   22,    0,    0,
1785      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1786      4  32,    0,   34,    0,   37,    0,   41,    0,   42,    0,
1787      4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0,   0,    0/
1788       DATA ((KFPR(I,J),J=1,2),I=151,200)/
1789      5  35,    0,   35,    0,   35,    0,    0,    0,    0,    0,
1790      5  36,    0,   36,    0,   36,    0,    0,    0,    0,    0,
1791      6   6,   37,   42,    0,   42,   42,   42,   42,   11,    0,
1792      6  11,    0, 0, 4000001, 0, 4000002, 0, 4000011,    0,    0,
1793      7  23,   35,   24,   35,   35,    0,   35,    0,    0,    0,
1794      7  23,   36,   24,   36,   36,    0,   36,    0,    0,    0,
1795      8  35,    6,   35,    6,   21,   35,    0,   35,   21,   35,
1796      8  36,    6,   36,    6,   21,   36,    0,   36,   21,   36,
1797      9  3000113, 0, 3000213, 0, 3000223, 0, 11,    0,   11,    0,
1798      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1799       DATA ((KFPR(I,J),J=1,2),I=201,240)/
1800      &  1000011,   1000011,   2000011,   2000011,   1000011,
1801      &  2000011,   1000013,   1000013,   2000013,   2000013,
1802      &  1000013,   2000013,   1000015,   1000015,   2000015,
1803      &  2000015,   1000015,   2000015,   1000011,   1000012,
1804      1  1000015,   1000016,   2000015,   1000016,   1000012,
1805      1  1000012,   1000016,   1000016,         0,         0,
1806      1  1000022,   1000022,   1000023,   1000023,   1000025,
1807      1  1000025,   1000035,   1000035,   1000022,   1000023,
1808      2  1000022,   1000025,   1000022,   1000035,   1000023,
1809      2  1000025,   1000023,   1000035,   1000025,   1000035,
1810      2  1000024,   1000024,   1000037,   1000037,   1000024,
1811      2  1000037,   1000022,   1000024,   1000023,   1000024,
1812      3  1000025,   1000024,   1000035,   1000024,   1000022,
1813      3  1000037,   1000023,   1000037,   1000025,   1000037,
1814      3  1000035,   1000037,   1000021,   1000022,   1000021,
1815      3  1000023,   1000021,   1000025,   1000021,   1000035/
1816       DATA ((KFPR(I,J),J=1,2),I=241,280)/
1817      4  1000021,   1000024,   1000021,   1000037,   1000021,
1818      4  1000021,   1000021,   1000021,         0,         0,
1819      4  1000002,   1000022,   2000002,   1000022,   1000002,
1820      4  1000023,   2000002,   1000023,   1000002,   1000025,
1821      5  2000002,   1000025,   1000002,   1000035,   2000002,
1822      5  1000035,   1000001,   1000024,   2000005,   1000024,
1823      5  1000001,   1000037,   2000005,   1000037,   1000002,
1824      5  1000021,   2000002,   1000021,         0,         0,
1825      6  1000006,   1000006,   2000006,   2000006,   1000006,
1826      6  2000006,   1000006,   1000006,   2000006,   2000006,
1827      6        0,         0,         0,         0,         0,
1828      6        0,         0,         0,         0,         0,
1829      7  1000002,   1000002,   2000002,   2000002,   1000002,
1830      7  2000002,   1000002,   1000002,   2000002,   2000002,
1831      7  1000002,   2000002,   1000002,   1000002,   2000002,
1832      7  2000002,   1000002,   1000002,   2000002,   2000002/
1833       DATA ((KFPR(I,J),J=1,2),I=281,350)/
1834      8  1000005,   1000002,   2000005,   2000002,   1000005,
1835      8  2000002,   1000005,   1000002,   2000005,   2000002,
1836      8  1000005,   2000002,   1000005,   1000005,   2000005,
1837      8  2000005,   1000005,   1000005,   2000005,   2000005,
1838      9  1000005,   1000005,   2000005,   2000005,   1000005,
1839      9  2000005,   1000005,   1000021,   2000005,   1000021,
1840      9  1000005,   2000005,        37,        25,        37,
1841      9       35,        36,        25,        36,        35,
1842      &       37,        37,      18*0,
1843 C...UED: 311-319
1844      &  5100021,   5100021, 
1845      &  5100002,   5100021, 
1846      &  5100002,   5100001,
1847      &  5100002,  -5100002, 
1848      &  5100002,  -5100002,
1849      &  5100002,  -6100001,
1850      &  5100002,  -5100001,
1851      &  5100002,   6100001,
1852      &  5100001,  -5100001,
1853      &  42*0,
1854      4  9900041,         0,   9900042,         0,   9900041,
1855      4       11,   9900042,        11,   9900041,        13,
1856      4  9900042,        13,   9900041,        15,   9900042,
1857      4       15,   9900041,   9900041,   9900042,   9900042/
1858       DATA ((KFPR(I,J),J=1,2),I=351,400)/
1859      5  9900041,         0,   9900042,         0,   9900023,
1860      5        0,   9900024,         0,         0,         0,
1861      5        0,         0,         0,         0,         0,
1862      5        0,         0,         0,         0,         0,
1863      6       24,        24,        24,   3000211,   3000211,
1864      6  3000211,        22,   3000111,        22,   3000221,
1865      6       23,   3000111,        23,   3000221,        24,
1866      6  3000211,         0,         0,        24,        23,
1867      7       24,   3000111,   3000211,        23,   3000211,
1868      7  3000111,        22,   3000211,        23,   3000211,
1869      7       24,   3000111,        24,   3000221,        22,
1870      7       24,        22,        23,        23,        23,
1871      8   0,    0,    0,    0,   21,   21,    0,   21,    0,    0,
1872      8  21,   21,    0,    0,    0,    0,    0,    0,    0,    0,
1873      9  5000039,         0,   5000039,         0,        21,
1874      9  5000039,         0,   5000039,        21,   5000039,
1875      9     10*0/
1876       DATA ((KFPR(I,J),J=1,2),I=401,500)/
1877      &  37,    6,   37,    6,    36*0,
1878      2      443,        21,   9900443,        21,   9900441,
1879      2       21,   9910441,        21,         0,   9900443,
1880      2        0,   9900441,         0,   9910441,        21,
1881      2  9900443,        21,   9900441,        21,   9910441,
1882      3 10441, 21, 20443,  21,  445,   21,    0, 10441,   0, 20443,
1883      3   0,  445,   21, 10441,  21, 20443,  21,  445,  42*0,
1884      6      553,        21,   9900553,        21,   9900551,
1885      6       21,   9910551,        21,         0,   9900553,
1886      6        0,   9900551,         0,   9910551,        21,
1887      6  9900553,        21,   9900551,        21,   9910551,
1888      7 10551, 21, 20553,  21,  555,   21,    0, 10551,   0, 20553,
1889      7   0,  555,   21, 10551,  21, 20553,  21,  555, 42*0/
1890       DATA COEF/10000*0D0/
1891       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1892      &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,
1893      &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,
1894      &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,
1895      &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,
1896      &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,
1897      &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,
1898      &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,
1899      &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,
1900      &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,
1901      &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/
1902  
1903 C...Treatment of resonances.
1904       DATA (MWID(I)  ,I=   1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,   
1905      &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1906      &81*0,21*1,4*1,25*0/
1907  
1908 C...Character constants: name of processes.
1909       DATA PROC(0)/                    'All included subprocesses   '/
1910       DATA (PROC(I),I=1,20)/
1911      &'f + fbar -> gamma*/Z0       ',  'f + fbar'' -> W+/-           ',
1912      &'f + fbar -> h0              ',  'gamma + W+/- -> W+/-        ',
1913      &'Z0 + Z0 -> h0               ',  'Z0 + W+/- -> W+/-           ',
1914      &'                            ',  'W+ + W- -> h0               ',
1915      &'                            ',  'f + f'' -> f + f'' (QFD)      ',
1916      1'f + f'' -> f + f'' (QCD)      ','f + fbar -> f'' + fbar''      ',
1917      1'f + fbar -> g + g           ',  'f + fbar -> g + gamma       ',
1918      1'f + fbar -> g + Z0          ',  'f + fbar'' -> g + W+/-       ',
1919      1'f + fbar -> g + h0          ',  'f + fbar -> gamma + gamma   ',
1920      1'f + fbar -> gamma + Z0      ',  'f + fbar'' -> gamma + W+/-   '/
1921       DATA (PROC(I),I=21,40)/
1922      2'f + fbar -> gamma + h0      ',  'f + fbar -> Z0 + Z0         ',
1923      2'f + fbar'' -> Z0 + W+/-      ', 'f + fbar -> Z0 + h0         ',
1924      2'f + fbar -> W+ + W-         ',  'f + fbar'' -> W+/- + h0      ',
1925      2'f + fbar -> h0 + h0         ',  'f + g -> f + g              ',
1926      2'f + g -> f + gamma          ',  'f + g -> f + Z0             ',
1927      3'f + g -> f'' + W+/-          ', 'f + g -> f + h0             ',
1928      3'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',
1929      3'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',
1930      3'f + gamma -> f + h0         ',  'f + Z0 -> f + g             ',
1931      3'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/
1932       DATA (PROC(I),I=41,60)/
1933      4'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + h0            ',
1934      4'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',
1935      4'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',
1936      4'f + W+/- -> f'' + h0         ', 'f + h0 -> f + g             ',
1937      4'f + h0 -> f + gamma         ',  'f + h0 -> f + Z0            ',
1938      5'f + h0 -> f'' + W+/-         ', 'f + h0 -> f + h0            ',
1939      5'g + g -> f + fbar           ',  'g + gamma -> f + fbar       ',
1940      5'g + Z0 -> f + fbar          ',  'g + W+/- -> f + fbar''       ',
1941      5'g + h0 -> f + fbar          ',  'gamma + gamma -> f + fbar   ',
1942      5'gamma + Z0 -> f + fbar      ',  'gamma + W+/- -> f + fbar''   '/
1943       DATA (PROC(I),I=61,80)/
1944      6'gamma + h0 -> f + fbar      ',  'Z0 + Z0 -> f + fbar         ',
1945      6'Z0 + W+/- -> f + fbar''      ', 'Z0 + h0 -> f + fbar         ',
1946      6'W+ + W- -> f + fbar         ',  'W+/- + h0 -> f + fbar''      ',
1947      6'h0 + h0 -> f + fbar         ',  'g + g -> g + g              ',
1948      6'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> Z0 + W+/-   ',
1949      7'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',
1950      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + h0          ',
1951      7'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',
1952      7'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + h0 -> W+/- + h0      ',
1953      7'h0 + h0 -> h0 + h0          ',  'q + gamma -> q'' + pi+/-     '/
1954       DATA (PROC(I),I=81,100)/
1955      8'q + qbar -> Q + Qbar, mass  ',  'g + g -> Q + Qbar, massive  ',
1956      8'f + q -> f'' + Q, massive    ', 'g + gamma -> Q + Qbar, mass ',
1957      8'gamma + gamma -> F + Fbar, m',  'g + g -> J/Psi + g          ',
1958      8'g + g -> chi_0c + g         ',  'g + g -> chi_1c + g         ',
1959      8'g + g -> chi_2c + g         ',  '                            ',
1960      9'Elastic scattering          ',  'Single diffractive (XB)     ',
1961      9'Single diffractive (AX)     ',  'Double  diffractive         ',
1962      9'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',
1963      9'                            ',  '                            ',
1964      9'q + gamma* -> q             ',  '                            '/
1965       DATA (PROC(I),I=101,120)/
1966      &'g + g -> gamma*/Z0          ',  'g + g -> h0                 ',
1967      &'gamma + gamma -> h0         ',  'g + g -> chi_0c             ',
1968      &'g + g -> chi_2c             ',  'g + g -> J/Psi + gamma      ',
1969      &'gamma + g -> J/Psi + g      ',  'gamma+gamma -> J/Psi + gamma',
1970      &'                            ',  'f + fbar -> gamma + h0      ',
1971      1'q + qbar -> g + h0          ',  'q + g -> q + h0             ',
1972      1'g + g -> g + h0             ',  'g + g -> gamma + gamma      ',
1973      1'g + g -> g + gamma          ',  'g + g -> gamma + Z0         ',
1974      1'g + g -> Z0 + Z0            ',  'g + g -> W+ + W-            ',
1975      1'                            ',  '                            '/
1976       DATA (PROC(I),I=121,140)/
1977      2'g + g -> Q + Qbar + h0      ',  'q + qbar -> Q + Qbar + h0   ',
1978      2'f + f'' -> f + f'' + h0       ',
1979      2'f + f'' -> f" + f"'' + h0     ',
1980      2'                            ',  '                            ',
1981      2'                            ',  '                            ',
1982      2'                            ',  '                            ',
1983      3'f + gamma*_T -> f + g       ',  'f + gamma*_L -> f + g       ',
1984      3'f + gamma*_T -> f + gamma   ',  'f + gamma*_L -> f + gamma   ',
1985      3'g + gamma*_T -> f + fbar    ',  'g + gamma*_L -> f + fbar    ',
1986      3'gamma*_T+gamma*_T -> f+fbar ',  'gamma*_T+gamma*_L -> f+fbar ',
1987      3'gamma*_L+gamma*_T -> f+fbar ',  'gamma*_L+gamma*_L -> f+fbar '/
1988       DATA (PROC(I),I=141,160)/
1989      4'f + fbar -> gamma*/Z0/Z''0   ', 'f + fbar'' -> W''+/-          ',
1990      4'f + fbar'' -> H+/-           ', 'f + fbar'' -> R              ',
1991      4'q + l -> LQ                 ',  'e + gamma -> e*             ',
1992      4'd + g -> d*                 ',  'u + g -> u*                 ',
1993      4'g + g -> eta_tc             ',  '                            ',
1994      5'f + fbar -> H0              ',  'g + g -> H0                 ',
1995      5'gamma + gamma -> H0         ',  '                            ',
1996      5'                            ',  'f + fbar -> A0              ',
1997      5'g + g -> A0                 ',  'gamma + gamma -> A0         ',
1998      5'                            ',  '                            '/
1999       DATA (PROC(I),I=161,180)/
2000      6'f + g -> f'' + H+/-          ', 'q + g -> LQ + lbar          ',
2001      6'g + g -> LQ + LQbar         ',  'q + qbar -> LQ + LQbar      ',
2002      6'f + fbar -> f'' + fbar'' (g/Z)',
2003      6'f +fbar'' -> f" + fbar"'' (W) ',
2004      6'q + q'' -> q" + d*           ',  'q + q'' -> q" + u*           ',
2005      6'q + qbar -> e + e*          ',  '                            ',
2006      7'f + fbar -> Z0 + H0         ', 'f + fbar'' -> W+/- + H0      ',
2007      7'f + f'' -> f + f'' + H0       ',
2008      7'f + f'' -> f" + f"'' + H0     ',
2009      7'                            ',  'f + fbar -> Z0 + A0         ',
2010      7'f + fbar'' -> W+/- + A0      ',
2011      7'f + f'' -> f + f'' + A0       ',
2012      7'f + f'' -> f" + f"'' + A0     ',
2013      7'                            '/
2014       DATA (PROC(I),I=181,200)/
2015      8'g + g -> Q + Qbar + H0      ',  'q + qbar -> Q + Qbar + H0   ',
2016      8'q + qbar -> g + H0          ',  'q + g -> q + H0             ',
2017      8'g + g -> g + H0             ',  'g + g -> Q + Qbar + A0      ',
2018      8'q + qbar -> Q + Qbar + A0   ',  'q + qbar -> g + A0          ',
2019      8'q + g -> q + A0             ',  'g + g -> g + A0             ',
2020      9'f + fbar -> rho_tc0         ',  'f + f'' -> rho_tc+/-         ',
2021      9'f + fbar -> omega_tc0      ',  'f+fbar -> f''+fbar'' (ETC)  ',
2022      9'f+fbar'' -> f"+fbar"'' (ETC)','                          ',
2023      9'                            ',  '                            ',
2024      9'                            ',  '                            '/
2025       DATA (PROC(I),I=201,220)/
2026      &'f + fbar -> ~e_L + ~e_Lbar  ',  'f + fbar -> ~e_R + ~e_Rbar  ',
2027      &'f + fbar -> ~e_R + ~e_Lbar  ',  'f + fbar -> ~mu_L + ~mu_Lbar',
2028      &'f + fbar -> ~mu_R + ~mu_Rbar',  'f + fbar -> ~mu_L + ~mu_Rbar',
2029      &'f+fbar -> ~tau_1 + ~tau_1bar',  'f+fbar -> ~tau_2 + ~tau_2bar',
2030      &'f+fbar -> ~tau_1 + ~tau_2bar',  'q + qbar'' -> ~l_L + ~nulbar ',
2031      1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2032      1'f + fbar -> ~nul + ~nulbar  ',  'f+fbar -> ~nutau + ~nutaubar',
2033      1'                            ',  'f + fbar -> ~chi1 + ~chi1   ',
2034      1'f + fbar -> ~chi2 + ~chi2   ',  'f + fbar -> ~chi3 + ~chi3   ',
2035      1'f + fbar -> ~chi4 + ~chi4   ',  'f + fbar -> ~chi1 + ~chi2   '/
2036       DATA (PROC(I),I=221,240)/
2037      2'f + fbar -> ~chi1 + ~chi3   ',  'f + fbar -> ~chi1 + ~chi4   ',
2038      2'f + fbar -> ~chi2 + ~chi3   ',  'f + fbar -> ~chi2 + ~chi4   ',
2039      2'f + fbar -> ~chi3 + ~chi4   ',  'f+fbar -> ~chi+-1 + ~chi-+1 ',
2040      2'f+fbar -> ~chi+-2 + ~chi-+2 ',  'f+fbar -> ~chi+-1 + ~chi-+2 ',
2041      2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2042      3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2043      3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2044      3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2045      3'q + qbar -> ~chi1 + ~g      ',  'q + qbar -> ~chi2 + ~g      ',
2046      3'q + qbar -> ~chi3 + ~g      ',  'q + qbar -> ~chi4 + ~g      '/
2047       DATA (PROC(I),I=241,260)/
2048      4'q + qbar'' -> ~chi+-1 + ~g   ', 'q + qbar'' -> ~chi+-2 + ~g  ',
2049      4'q + qbar -> ~g + ~g         ',  'g + g -> ~g + ~g            ',
2050      4'                            ',  'qj + g -> ~qj_L + ~chi1     ',
2051      4'qj + g -> ~qj_R + ~chi1     ',  'qj + g -> ~qj_L + ~chi2     ',
2052      4'qj + g -> ~qj_R + ~chi2     ',  'qj + g -> ~qj_L + ~chi3     ',
2053      5'qj + g -> ~qj_R + ~chi3     ',  'qj + g -> ~qj_L + ~chi4     ',
2054      5'qj + g -> ~qj_R + ~chi4     ',  'qj + g -> ~qk_L + ~chi+-1   ',
2055      5'qj + g -> ~qk_R + ~chi+-1   ',  'qj + g -> ~qk_L + ~chi+-2   ',
2056      5'qj + g -> ~qk_R + ~chi+-2   ',  'qj + g -> ~qj_L + ~g        ',
2057      5'qj + g -> ~qj_R + ~g        ',  '                            '/
2058       DATA (PROC(I),I=261,300)/
2059      6'f + fbar -> ~t_1 + ~t_1bar  ',  'f + fbar -> ~t_2 + ~t_2bar  ',
2060      6'f + fbar -> ~t_1 + ~t_2bar  ',  'g + g -> ~t_1 + ~t_1bar     ',
2061      6'g + g -> ~t_2 + ~t_2bar     ',  '                            ',
2062      6'                            ',  '                            ',
2063      6'                            ',  '                            ',
2064      7'qi + qj -> ~qi_L + ~qj_L    ',  'qi + qj -> ~qi_R + ~qj_R    ',
2065      7'qi + qj -> ~qi_L + ~qj_R    ',  'qi+qjbar -> ~qi_L + ~qj_Lbar',
2066      7'qi+qjbar -> ~qi_R + ~qj_Rbar',  'qi+qjbar -> ~qi_L + ~qj_Rbar',
2067      7'f + fbar -> ~qi_L + ~qi_Lbar',  'f + fbar -> ~qi_R + ~qi_Rbar',
2068      7'g + g -> ~qi_L + ~qi_Lbar   ',  'g + g -> ~qi_R + ~qi_Rbar   ',
2069      8'b + qj -> ~b_1 + ~qj_L      ',  'b + qj -> ~b_2 + ~qj_R      ',
2070      8'b + qj -> ~b_1 + ~qj_R      ',  'b + qjbar -> ~b_1 + ~qj_Lbar',
2071      8'b + qjbar -> ~b_2 + ~qj_Rbar',  'b + qjbar -> ~b_1 + ~qj_Rbar',
2072      8'f + fbar -> ~b_1 + ~b_1bar  ',  'f + fbar -> ~b_2 + ~b_2bar  ',
2073      8'g + g -> ~b_1 + ~b_1bar     ',  'g + g -> ~b_2 + ~b_2bar     ',
2074      9'b + b -> ~b_1 + ~b_1        ',  'b + b -> ~b_2 + ~b_2        ',
2075      9'b + b -> ~b_1 + ~b_2        ',  'b + g -> ~b_1 + ~g          ',
2076      9'b + g -> ~b_2 + ~g          ',  'b + bbar -> ~b_1 + ~b_2bar  ',
2077      9'f + fbar'' -> H+/- + h0     ',  'f + fbar -> H+/- + H0       ',
2078      9'f + fbar -> A0 + h0         ',  'f + fbar -> A0 + H0         '/
2079       DATA (PROC(I),I=301,340)/
2080      &'f + fbar -> H+ + H-         ',
2081      &9*'                          ',  'g + g -> g* + g*            ',
2082      &'q + g -> q*_D + g*          ',  'qi + qj -> q*_Di + q*_Dj    ',
2083      &'g + g -> q*_D + q*_Dbar     ',  'q  + qbar -> q*_D + q*_Dbar ',
2084      &'qi + qbarj -> q*Di + q*Sbarj',  'qi + qjbar -> q*Di + q*Dbarj',
2085      &'qi + qj -> q*_Di + q*_Sj    ',  'qi + qibar -> q*Dj + q*Dbarj',
2086      &21*'                          '/
2087       DATA (PROC(I),I=341,380)/
2088      4'l + l -> H_L++/--           ',  'l + l -> H_R++/--           ',
2089      4'l + gamma -> H_L++/-- e-/+  ',  'l + gamma -> H_R++/-- e-/+  ',
2090      4'l + gamma -> H_L++/-- mu-/+ ',  'l + gamma -> H_R++/-- mu-/+ ',
2091      4'l + gamma -> H_L++/-- tau-/+',  'l + gamma -> H_R++/-- tau-/+',
2092      4'f + fbar -> H_L++ + H_L--   ',  'f + fbar -> H_R++ + H_R--   ',
2093      5'f + f -> f'' + f'' + H_L++/-- ',
2094      5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0            ',
2095      5'f + fbar'' -> W_R+/-         ',5*'                            ',
2096      6'                            ',  'f + fbar -> W_L+ W_L-       ',
2097      6'f + fbar -> W_L+/- pi_T-/+  ',  'f + fbar -> pi_T+ pi_T-     ',
2098      6'f + fbar -> gamma pi_T0     ',  'f + fbar -> gamma pi_T0''    ',
2099      6'f + fbar -> Z0 pi_T0        ',  'f + fbar -> Z0 pi_T0''       ',
2100      6'f + fbar -> W+/- pi_T-/+    ',  '                            ',
2101      7'f + fbar'' -> W_L+/- Z_L0    ', 'f + fbar'' -> W_L+/- pi_T0   ',
2102      7'f + fbar'' -> pi_T+/- Z_L0   ', 'f + fbar'' -> pi_T+/- pi_T0  ',
2103      7'f + fbar'' -> gamma pi_T+/-  ', 'f + fbar'' -> Z0 pi_T+/-     ',
2104      7'f + fbar'' -> W+/- pi_T0     ',
2105      7'f + fbar'' -> W+/- pi_T0''    ',
2106      7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2107      7'f + fbar -> Z0 Z0 (ETC)     '/
2108       DATA (PROC(I),I=381,420)/
2109      8'f + f'' -> f + f'' (ETC)      ','f + fbar -> f'' + fbar'' (ETC)',
2110      8'f + fbar -> g + g (ETC)     ',  'f + g -> f + g (ETC)        ',
2111      8'g + g -> f + fbar (ETC)     ',  'g + g -> g + g (ETC)        ',
2112      8'q + qbar -> Q + Qbar (ETC)  ',  'g + g -> Q + Qbar (ETC)     ',
2113      8'                            ',  '                            ',
2114      9'f + fbar -> G*              ',  'g + g -> G*                 ',
2115      9'q + qbar -> g + G*          ',  'q + g -> q + G*             ',
2116      9'g + g -> g + G*             ',  '                            ',
2117      9 4*'                         ',
2118      &'g + g -> t + b + H+/-       ',  'q + qbar -> t + b + H+/-    ',
2119      & 18*'                            '/
2120       DATA (PROC(I),I=421,460)/
2121      2'g + g  -> cc~[3S1(1)] + g   ',  'g + g  -> cc~[3S1(8)] + g   ',
2122      2'g + g  -> cc~[1S0(8)] + g   ',  'g + g  -> cc~[3PJ(8)] + g   ',
2123      2'g + q  -> q + cc~[3S1(8)]   ',  'g + q  -> q + cc~[1S0(8)]   ',
2124      2'g + q  -> q + cc~[3PJ(8)]   ',  'q + q~ -> g + cc~[3S1(8)]   ',
2125      2'q + q~ -> g + cc~[1S0(8)]   ',  'q + q~ -> g + cc~[3PJ(8)]   ',
2126      3'g + g  -> cc~[3P0(1)] + g   ',  'g + g  -> cc~[3P1(1)] + g   ',
2127      3'g + g  -> cc~[3P2(1)] + g   ',  'q + g  -> q + cc~[3P0(1)]   ',
2128      3'q + g  -> q + cc~[3P1(1)]   ',  'q + g  -> q + cc~[3P2(1)]   ',
2129      3'q + q~ -> g + cc~[3P0(1)]   ',  'q + q~ -> g + cc~[3P1(1)]   ',
2130      3'q + q~ -> g + cc~[3P2(1)]   ',
2131      3     21 *'                            '/
2132       DATA (PROC(I),I=461,500)/
2133      6'g + g  -> bb~[3S1(1)] + g   ',  'g + g  -> bb~[3S1(8)] + g   ',
2134      6'g + g  -> bb~[1S0(8)] + g   ',  'g + g  -> bb~[3PJ(8)] + g   ',
2135      6'g + q  -> q + bb~[3S1(8)]   ',  'g + q  -> q + bb~[1S0(8)]   ',
2136      6'g + q  -> q + bb~[3PJ(8)]   ',  'q + q~ -> g + bb~[3S1(8)]   ',
2137      6'q + q~ -> g + bb~[1S0(8)]   ',  'q + q~ -> g + bb~[3PJ(8)]   ',
2138      7'g + g  -> bb~[3P0(1)] + g   ',  'g + g  -> bb~[3P1(1)] + g   ',
2139      7'g + g  -> bb~[3P2(1)] + g   ',  'q + g  -> q + bb~[3P0(1)]   ',
2140      7'q + g  -> q + bb~[3P1(1)]   ',  'q + g  -> q + bb~[3P2(1)]   ',
2141      7'q + q~ -> g + bb~[3P0(1)]   ',  'q + q~ -> g + bb~[3P1(1)]   ',
2142      7'q + q~ -> g + bb~[3P2(1)]   ',
2143      7     21 *'                            '/
2144  
2145 C...Cross sections and slope offsets.
2146       DATA SIGT/294*0D0/
2147  
2148 C...Supersymmetry switches and parameters.
2149       DATA IMSS/0,
2150      &  0,  0,  0,  1,  0,  0,  0,  0,  0,  0,
2151      1  89*0/
2152       DATA RMSS/0D0,
2153      &  80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2154      1  700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2155      2   1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2156      3  10*0D0,  
2157      4  0D0,1D0,8*0D0,  
2158      5  49*0D0/
2159 C...Initial values for R-violating SUSY couplings.
2160 C...Should not be changed here. See PYMSIN.
2161       DATA RVLAM/27*0D0/
2162       DATA RVLAMP/27*0D0/
2163       DATA RVLAMB/27*0D0/
2164  
2165 C...Technicolor switches and parameters
2166       DATA ITCM/0,
2167      &  4,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2168      1  89*0/
2169       DATA RTCM/0D0,
2170      &  82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2171      1  .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2172      2  .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2173      3  .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2174      4  1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2175      4  200D0, 48*0D0/
2176  
2177 C...UED switches and parameters.
2178 C... IUED(0) empty IUED vector element
2179 C... IUED(1) UED ON(=1)/OFF(=0) switch
2180 C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2181 C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2182 C... IUED(4) N the number of large extra dimensions
2183 C... IUED(5) Selects whether the code takes Lambda (=0)
2184 C...         or Lambda*R (=1) as input.
2185 C... IUED(6) With radiative corrections to the masses (=1)
2186 C...         or without (=0)
2187 C...
2188 C... RUED(0) empty RUED vector element
2189 C... RUED(1) RINV (1/R) the curvature of the extra dimension
2190 C... RUED(2) XMD the (4+N)-dimensional Planck scale
2191 C... RUED(3) LAMUED (Lambda cutoff scale)
2192 C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2193 C...
2194       DATA IUED/0,0,0,5,6,0,1,93*0/
2195       DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2196 
2197 C...Data for histogramming routines.
2198       DATA IHIST/1000,20000,55,1/
2199       DATA INDX/1000*0/
2200 
2201 C...Data for SUSY Les Houches Accord.
2202       DATA CPRO/'PYTHIA      ','PYTHIA      '/
2203       DATA CVER/'6.4         ','6.4         '/
2204       DATA MODSEL/200*0/
2205       DATA PARMIN/100*0D0/
2206       DATA RMSOFT/101*0D0/
2207       DATA AU/9*0D0/
2208       DATA AD/9*0D0/
2209       DATA AE/9*0D0/
2210  
2211       END
2212  
2213 C*********************************************************************
2214  
2215 C...PYCKBD
2216 C...Check that BLOCK DATA PYDATA has been loaded.
2217 C...Should not be required, except that some compilers/linkers
2218 C...are pretty buggy in this respect.
2219  
2220       SUBROUTINE PYCKBD
2221  
2222 C...Double precision and integer declarations.
2223       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2224       IMPLICIT INTEGER(I-N)
2225       INTEGER PYK,PYCHGE,PYCOMP
2226 C...Commonblocks.
2227       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2228       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2229       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2230       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2231       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2232       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2233       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2234  
2235 C...Check a few variables to see they have been sensibly initialized.
2236       IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2237      &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2238      &MSTP(1).GT.5) THEN
2239 C...If not, abort the run right away.
2240         WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2241         WRITE(*,*) 'The program execution is stopped now!'
2242         CALL PYSTOP(8)
2243       ENDIF
2244  
2245       RETURN
2246       END
2247  
2248 C*********************************************************************
2249  
2250 C...PYTEST
2251 C...A simple program (disguised as subroutine) to run at installation
2252 C...as a check that the program works as intended.
2253  
2254       SUBROUTINE PYTEST(MTEST)
2255  
2256 C...Double precision and integer declarations.
2257       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2258       IMPLICIT INTEGER(I-N)
2259       INTEGER PYK,PYCHGE,PYCOMP
2260 C...Commonblocks.
2261       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2262       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2263       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2264       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2265       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2266       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2267       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2268 C...Local arrays.
2269       DIMENSION PSUM(5),PINI(6),PFIN(6)
2270  
2271 C...Save defaults for values that are changed.
2272       MSTJ1=MSTJ(1)
2273       MSTJ3=MSTJ(3)
2274       MSTJ11=MSTJ(11)
2275       MSTJ42=MSTJ(42)
2276       MSTJ43=MSTJ(43)
2277       MSTJ44=MSTJ(44)
2278       PARJ17=PARJ(17)
2279       PARJ22=PARJ(22)
2280       PARJ43=PARJ(43)
2281       PARJ54=PARJ(54)
2282       MST101=MSTJ(101)
2283       MST104=MSTJ(104)
2284       MST105=MSTJ(105)
2285       MST107=MSTJ(107)
2286       MST116=MSTJ(116)
2287  
2288 C...First part: loop over simple events to be generated.
2289       IF(MTEST.GE.1) CALL PYTABU(20)
2290       NERR=0
2291       DO 180 IEV=1,500
2292  
2293 C...Reset parameter values. Switch on some nonstandard features.
2294         MSTJ(1)=1
2295         MSTJ(3)=0
2296         MSTJ(11)=1
2297         MSTJ(42)=2
2298         MSTJ(43)=4
2299         MSTJ(44)=2
2300         PARJ(17)=0.1D0
2301         PARJ(22)=1.5D0
2302         PARJ(43)=1D0
2303         PARJ(54)=-0.05D0
2304         MSTJ(101)=5
2305         MSTJ(104)=5
2306         MSTJ(105)=0
2307         MSTJ(107)=1
2308         IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2309  
2310 C...Ten events each for some single jets configurations.
2311         IF(IEV.LE.50) THEN
2312           ITY=(IEV+9)/10
2313           MSTJ(3)=-1
2314           IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2315           IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2316           IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2317           IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2318           IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2319           IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2320  
2321 C...Ten events each for some simple jet systems; string fragmentation.
2322         ELSEIF(IEV.LE.130) THEN
2323           ITY=(IEV-41)/10
2324           IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2325           IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2326           IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2327           IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2328           IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2329           IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2330           IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2331           IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2332      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2333  
2334 C...Seventy events with independent fragmentation and momentum cons.
2335         ELSEIF(IEV.LE.200) THEN
2336           ITY=1+(IEV-131)/16
2337           MSTJ(2)=1+MOD(IEV-131,4)
2338           MSTJ(3)=1+MOD((IEV-131)/4,4)
2339           IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2340           IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2341           IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2342      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2343           IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2344      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2345  
2346 C...A hundred events with random jets (check invariant mass).
2347         ELSEIF(IEV.LE.300) THEN
2348   100     DO 110 J=1,5
2349             PSUM(J)=0D0
2350   110     CONTINUE
2351           NJET=2D0+6D0*PYR(0)
2352           DO 130 I=1,NJET
2353             KFL=21
2354             IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2355             IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2356             EJET=5D0+20D0*PYR(0)
2357             THETA=ACOS(2D0*PYR(0)-1D0)
2358             PHI=6.2832D0*PYR(0)
2359             IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2360             IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2361             IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2362             IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2363             DO 120 J=1,4
2364               PSUM(J)=PSUM(J)+P(I,J)
2365   120       CONTINUE
2366   130     CONTINUE
2367           IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2368      &    (PSUM(5)+PARJ(32))**2) GOTO 100
2369  
2370 C...Fifty e+e- continuum events with matrix elements.
2371         ELSEIF(IEV.LE.350) THEN
2372           MSTJ(101)=2
2373           CALL PYEEVT(0,40D0)
2374  
2375 C...Fifty e+e- continuum event with varying shower options.
2376         ELSEIF(IEV.LE.400) THEN
2377           MSTJ(42)=1+MOD(IEV,2)
2378           MSTJ(43)=1+MOD(IEV/2,4)
2379           MSTJ(44)=MOD(IEV/8,3)
2380           CALL PYEEVT(0,90D0)
2381  
2382 C...Fifty e+e- continuum events with coherent shower.
2383         ELSEIF(IEV.LE.450) THEN
2384           CALL PYEEVT(0,500D0)
2385  
2386 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2387         ELSE
2388           CALL PYONIA(5,9.46D0)
2389         ENDIF
2390  
2391 C...Generate event. Find total momentum, energy and charge.
2392         DO 140 J=1,4
2393           PINI(J)=PYP(0,J)
2394   140   CONTINUE
2395         PINI(6)=PYP(0,6)
2396         CALL PYEXEC
2397         DO 150 J=1,4
2398           PFIN(J)=PYP(0,J)
2399   150   CONTINUE
2400         PFIN(6)=PYP(0,6)
2401  
2402 C...Check conservation of energy, momentum and charge;
2403 C...usually exact, but only approximate for single jets.
2404         MERR=0
2405         IF(IEV.LE.50) THEN
2406           IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2407      &    MERR=MERR+1
2408           EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2409           IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2410           IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2411         ELSE
2412           DO 160 J=1,4
2413             IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2414   160     CONTINUE
2415           IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2416         ENDIF
2417         IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2418      &  (PFIN(J),J=1,4),PFIN(6)
2419  
2420 C...Check that all KF codes are known ones, and that partons/particles
2421 C...satisfy energy-momentum-mass relation. Store particle statistics.
2422         DO 170 I=1,N
2423           IF(K(I,1).GT.20) GOTO 170
2424           IF(PYCOMP(K(I,2)).EQ.0) THEN
2425             WRITE(MSTU(11),5100) I
2426             MERR=MERR+1
2427           ENDIF
2428           PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2429           IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2430      &    THEN
2431             WRITE(MSTU(11),5200) I
2432             MERR=MERR+1
2433           ENDIF
2434   170   CONTINUE
2435         IF(MTEST.GE.1) CALL PYTABU(21)
2436  
2437 C...List all erroneous events and some normal ones.
2438         IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2439           IF(MERR.GE.1) WRITE(MSTU(11),6400)
2440           CALL PYLIST(2)
2441         ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2442           CALL PYLIST(1)
2443         ENDIF
2444  
2445 C...Stop execution if too many errors.
2446         IF(MERR.NE.0) NERR=NERR+1
2447         IF(NERR.GE.10) THEN
2448           WRITE(MSTU(11),6300)
2449           CALL PYLIST(1)
2450           CALL PYSTOP(9)
2451         ENDIF
2452   180 CONTINUE
2453  
2454 C...Summarize result of run.
2455       IF(MTEST.GE.1) CALL PYTABU(22)
2456  
2457 C...Reset commonblock variables changed during run.
2458       MSTJ(1)=MSTJ1
2459       MSTJ(3)=MSTJ3
2460       MSTJ(11)=MSTJ11
2461       MSTJ(42)=MSTJ42
2462       MSTJ(43)=MSTJ43
2463       MSTJ(44)=MSTJ44
2464       PARJ(17)=PARJ17
2465       PARJ(22)=PARJ22
2466       PARJ(43)=PARJ43
2467       PARJ(54)=PARJ54
2468       MSTJ(101)=MST101
2469       MSTJ(104)=MST104
2470       MSTJ(105)=MST105
2471       MSTJ(107)=MST107
2472       MSTJ(116)=MST116
2473  
2474 C...Second part: complete events of various kinds.
2475 C...Common initial values. Loop over initiating conditions.
2476       MSTP(122)=MAX(0,MIN(2,MTEST))
2477       MDCY(PYCOMP(111),1)=0
2478       DO 230 IPROC=1,8
2479  
2480 C...Reset process type, kinematics cuts, and the flags used.
2481         MSEL=0
2482         DO 190 ISUB=1,500
2483           MSUB(ISUB)=0
2484   190   CONTINUE
2485         CKIN(1)=2D0
2486         CKIN(3)=0D0
2487         MSTP(2)=1
2488         MSTP(11)=0
2489         MSTP(33)=0
2490         MSTP(81)=1
2491         MSTP(82)=1
2492         MSTP(111)=1
2493         MSTP(131)=0
2494         MSTP(133)=0
2495         PARP(131)=0.01D0
2496  
2497 C...Prompt photon production at fixed target.
2498         IF(IPROC.EQ.1) THEN
2499           PZSUM=300D0
2500           PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2501           PQSUM=2D0
2502           MSEL=10
2503           CKIN(3)=5D0
2504           CALL PYINIT('FIXT','pi+','p',PZSUM)
2505  
2506 C...QCD processes at ISR energies.
2507         ELSEIF(IPROC.EQ.2) THEN
2508           PESUM=63D0
2509           PZSUM=0D0
2510           PQSUM=2D0
2511           MSEL=1
2512           CKIN(3)=5D0
2513           CALL PYINIT('CMS','p','p',PESUM)
2514  
2515 C...W production + multiple interactions at CERN Collider.
2516         ELSEIF(IPROC.EQ.3) THEN
2517           PESUM=630D0
2518           PZSUM=0D0
2519           PQSUM=0D0
2520           MSEL=12
2521           CKIN(1)=20D0
2522           MSTP(82)=4
2523           MSTP(2)=2
2524           MSTP(33)=3
2525           CALL PYINIT('CMS','p','pbar',PESUM)
2526  
2527 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2528         ELSEIF(IPROC.EQ.4) THEN
2529           PESUM=1800D0
2530           PZSUM=0D0
2531           PQSUM=0D0
2532           MSUB(22)=1
2533           MSUB(23)=1
2534           MSUB(25)=1
2535           CKIN(1)=200D0
2536           MSTP(111)=0
2537           MSTP(131)=1
2538           MSTP(133)=2
2539           PARP(131)=0.04D0
2540           CALL PYINIT('CMS','p','pbar',PESUM)
2541  
2542 C...Higgs production at LHC.
2543         ELSEIF(IPROC.EQ.5) THEN
2544           PESUM=15400D0
2545           PZSUM=0D0
2546           PQSUM=2D0
2547           MSUB(3)=1
2548           MSUB(102)=1
2549           MSUB(123)=1
2550           MSUB(124)=1
2551           PMAS(25,1)=300D0
2552           CKIN(1)=200D0
2553           MSTP(81)=0
2554           MSTP(111)=0
2555           CALL PYINIT('CMS','p','p',PESUM)
2556  
2557 C...Z' production at SSC.
2558         ELSEIF(IPROC.EQ.6) THEN
2559           PESUM=40000D0
2560           PZSUM=0D0
2561           PQSUM=2D0
2562           MSEL=21
2563           PMAS(32,1)=600D0
2564           CKIN(1)=400D0
2565           MSTP(81)=0
2566           MSTP(111)=0
2567           CALL PYINIT('CMS','p','p',PESUM)
2568  
2569 C...W pair production at 1 TeV e+e- collider.
2570         ELSEIF(IPROC.EQ.7) THEN
2571           PESUM=1000D0
2572           PZSUM=0D0
2573           PQSUM=0D0
2574           MSUB(25)=1
2575           MSUB(69)=1
2576           MSTP(11)=1
2577           CALL PYINIT('CMS','e+','e-',PESUM)
2578  
2579 C...Deep inelastic scattering at a LEP+LHC ep collider.
2580         ELSEIF(IPROC.EQ.8) THEN
2581           P(1,1)=0D0
2582           P(1,2)=0D0
2583           P(1,3)=8000D0
2584           P(2,1)=0D0
2585           P(2,2)=0D0
2586           P(2,3)=-80D0
2587           PESUM=8080D0
2588           PZSUM=7920D0
2589           PQSUM=0D0
2590           MSUB(10)=1
2591           CKIN(3)=50D0
2592           MSTP(111)=0
2593           CALL PYINIT('3MOM','p','e-',PESUM)
2594         ENDIF
2595  
2596 C...Generate 20 events of each required type.
2597         DO 220 IEV=1,20
2598           CALL PYEVNT
2599           PESUMM=PESUM
2600           IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2601  
2602 C...Check conservation of energy/momentum/flavour.
2603           PINI(1)=0D0
2604           PINI(2)=0D0
2605           PINI(3)=PZSUM
2606           PINI(4)=PESUMM
2607           PINI(6)=PQSUM
2608           DO 200 J=1,4
2609             PFIN(J)=PYP(0,J)
2610   200     CONTINUE
2611           PFIN(6)=PYP(0,6)
2612           MERR=0
2613           DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2614           DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2615           DEVQ=ABS(PFIN(6)-PINI(6))
2616           IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2617      &    DEVQ.GT.0.1D0) MERR=1
2618           IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2619      &    (PFIN(J),J=1,4),PFIN(6)
2620  
2621 C...Check that all KF codes are known ones, and that partons/particles
2622 C...satisfy energy-momentum-mass relation.
2623           DO 210 I=1,N
2624             IF(K(I,1).GT.20) GOTO 210
2625             IF(PYCOMP(K(I,2)).EQ.0) THEN
2626               WRITE(MSTU(11),5100) I
2627               MERR=MERR+1
2628             ENDIF
2629             PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2630      &      SIGN(1D0,P(I,5))
2631             IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2632      &      .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2633               WRITE(MSTU(11),5200) I
2634               MERR=MERR+1
2635             ENDIF
2636   210     CONTINUE
2637  
2638 C...Listing of erroneous events, and first event of each type.
2639           IF(MERR.GE.1) NERR=NERR+1
2640           IF(NERR.GE.10) THEN
2641             WRITE(MSTU(11),6300)
2642             CALL PYLIST(1)
2643             CALL PYSTOP(9)
2644           ENDIF
2645           IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2646             IF(MERR.GE.1) WRITE(MSTU(11),6400)
2647             CALL PYLIST(1)
2648           ENDIF
2649   220   CONTINUE
2650  
2651 C...List statistics for each process type.
2652         IF(MTEST.GE.1) CALL PYSTAT(1)
2653   230 CONTINUE
2654  
2655 C...Summarize result of run.
2656       IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2657       IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2658  
2659 C...Format statements for output.
2660  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2661      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2662      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2663      &4(1X,F12.5),1X,F8.2)
2664  5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2665  5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2666      &'kinematics')
2667  6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2668      &'wrong.'/5X,'Execution will be stopped after listing of event.')
2669  6400 FORMAT(5X,'Faulty event follows:')
2670  6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2671  6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2672      &5X,'This should not have happened!')
2673  
2674       RETURN
2675       END
2676  
2677 C*********************************************************************
2678  
2679 C...PYHEPC
2680 C...Converts PYTHIA event record contents to or from
2681 C...the standard event record commonblock.
2682  
2683       SUBROUTINE PYHEPC(MCONV)
2684  
2685 C...Double precision and integer declarations.
2686       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2687       IMPLICIT INTEGER(I-N)
2688       INTEGER PYK,PYCHGE,PYCOMP
2689 C...Commonblocks.
2690       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2691       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2692       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2693       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2694 C...HEPEVT commonblock.
2695       PARAMETER (NMXHEP=4000)
2696       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2697      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2698       DOUBLE PRECISION PHEP,VHEP
2699       SAVE /HEPEVT/
2700       
2701 C...Store HEPEVT commonblock size (for interfacing issues).
2702       MSTU(8)=NMXHEP
2703       
2704 C...Initialize variable(s)
2705       INEW = 1
2706  
2707 C...Conversion from PYTHIA to standard, the easy part.
2708       IF(MCONV.EQ.1) THEN
2709         NEVHEP=0
2710         IF(N.GT.NMXHEP) CALL PYERRM(8,
2711      &  '(PYHEPC:) no more space in /HEPEVT/')
2712         NHEP=MIN(N,NMXHEP)
2713         DO 150 I=1,NHEP
2714           ISTHEP(I)=0
2715           IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2716           IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2717           IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2718           IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2719           IDHEP(I)=K(I,2)
2720           JMOHEP(1,I)=K(I,3)
2721           JMOHEP(2,I)=0
2722           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2723             JDAHEP(1,I)=K(I,4)
2724             JDAHEP(2,I)=K(I,5)
2725           ELSE
2726             JDAHEP(1,I)=0
2727             JDAHEP(2,I)=0
2728           ENDIF
2729           DO 100 J=1,5
2730             PHEP(J,I)=P(I,J)
2731   100     CONTINUE
2732           DO 110 J=1,4
2733             VHEP(J,I)=V(I,J)
2734   110     CONTINUE
2735  
2736 C...Check if new event (from pileup).
2737           IF(I.EQ.1) THEN
2738             INEW=1
2739           ELSE
2740             IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2741           ENDIF
2742  
2743 C...Fill in missing mother information.
2744           IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2745             IMO1=I-2
2746   120       IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2747      &      THEN
2748               IMO1=IMO1-1
2749               GOTO 120
2750             ENDIF
2751             JMOHEP(1,I)=IMO1
2752             JMOHEP(2,I)=IMO1+1
2753           ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2754             I1=K(I,3)-1
2755   130       I1=I1+1
2756             IF(I1.GE.I) CALL PYERRM(8,
2757      &      '(PYHEPC:) translation of inconsistent event history')
2758             IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2759             KC=PYCOMP(K(I1,2))
2760             IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2761             IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2762             JMOHEP(2,I)=I1
2763           ELSEIF(K(I,2).EQ.94) THEN
2764             NJET=2
2765             IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2766             IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2767             JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2768             IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2769      &      MOD(K(I+1,4)/MSTU(5),MSTU(5))
2770           ENDIF
2771  
2772 C...Fill in missing daughter information.
2773           IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2774             DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2775               I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2776               JDAHEP(1,I2)=I
2777   140       CONTINUE
2778           ENDIF
2779           IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2780           I1=JMOHEP(1,I)
2781           IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2782           IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2783           IF(JDAHEP(1,I1).EQ.0) THEN
2784             JDAHEP(1,I1)=I
2785           ELSE
2786             JDAHEP(2,I1)=I
2787           ENDIF
2788   150   CONTINUE
2789         DO 160 I=1,NHEP
2790           IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2791           IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2792   160   CONTINUE
2793  
2794 C...Conversion from standard to PYTHIA, the easy part.
2795       ELSE
2796         IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2797      &  '(PYHEPC:) no more space in /PYJETS/')
2798         N=MIN(NHEP,MSTU(4))
2799         NKQ=0
2800         KQSUM=0
2801         DO 190 I=1,N
2802           K(I,1)=0
2803           IF(ISTHEP(I).EQ.1) K(I,1)=1
2804           IF(ISTHEP(I).EQ.2) THEN
2805              K(I,1)=11
2806              IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND.
2807      $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND.
2808      $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12
2809           ENDIF
2810           IF(ISTHEP(I).EQ.3) K(I,1)=21
2811           K(I,2)=IDHEP(I)
2812           K(I,3)=JMOHEP(1,I)
2813           K(I,4)=JDAHEP(1,I)
2814           K(I,5)=JDAHEP(2,I)
2815           DO 170 J=1,5
2816             P(I,J)=PHEP(J,I)
2817   170     CONTINUE
2818           DO 180 J=1,4
2819             V(I,J)=VHEP(J,I)
2820   180     CONTINUE
2821           V(I,5)=0D0
2822           IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2823             I1=JDAHEP(1,I)
2824             IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2825      &      PHEP(5,I)/PHEP(4,I)
2826           ENDIF
2827  
2828 C...Fill in missing information on colour connection in jet systems.
2829           IF(ISTHEP(I).EQ.1) THEN
2830             KC=PYCOMP(K(I,2))
2831             KQ=0
2832             IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2833             IF(KQ.NE.0) NKQ=NKQ+1
2834             IF(KQ.NE.2) KQSUM=KQSUM+KQ
2835             IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2836               K(I,1)=2
2837             ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2838               IF(K(I+1,2).EQ.21) K(I,1)=2
2839             ENDIF
2840           ENDIF
2841   190   CONTINUE
2842         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2843      &  '(PYHEPC:) input parton configuration not colour singlet')
2844       ENDIF
2845  
2846       END
2847  
2848 C*********************************************************************
2849  
2850 C...PYINIT
2851 C...Initializes the generation procedure; finds maxima of the
2852 C...differential cross-sections to be used for weighting.
2853  
2854       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2855  
2856 C...Double precision and integer declarations.
2857       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2858       IMPLICIT INTEGER(I-N)
2859       INTEGER PYK,PYCHGE,PYCOMP
2860 C...Commonblocks.
2861       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2862       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2863       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2864       COMMON/PYDAT4/CHAF(500,2)
2865       CHARACTER CHAF*16
2866       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2867       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2868       COMMON/PYINT1/MINT(400),VINT(400)
2869       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2870       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2871       COMMON/PYPUED/IUED(0:99),RUED(0:99)
2872       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2873      &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2874 C...Local arrays and character variables.
2875       DIMENSION ALAMIN(20),NFIN(20)
2876       CHARACTER*(*) FRAME,BEAM,TARGET
2877       CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2878  
2879 C...Interface to PDFLIB.
2880       COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2881       COMMON/W50512/QCDL4,QCDL5
2882       SAVE /W50511/,/W50512/
2883       DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2884       CHARACTER*20 PARM(20)
2885       DATA VALUE/20*0D0/,PARM/20*' '/
2886  
2887 C...Data:Lambda and n_f values for parton distributions..
2888       DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2889      &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2890      &NFIN/20*4/
2891       DATA CHLH/'lepton','hadron'/
2892  
2893 C...Check that BLOCK DATA PYDATA has been loaded.
2894       CALL PYCKBD
2895  
2896 C...Reset MINT and VINT arrays. Write headers.
2897       MSTI(53)=0
2898       DO 100 J=1,400
2899         MINT(J)=0
2900         VINT(J)=0D0
2901   100 CONTINUE
2902       IF(MSTU(12).NE.12345) CALL PYLIST(0)
2903       IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2904  
2905 C...Reset error counters.
2906       MSTU(23)=0
2907       MSTU(27)=0
2908       MSTU(30)=0
2909  
2910 C...Reset processes that should not be on.
2911       MSUB(96)=0
2912       MSUB(97)=0
2913  
2914 C...Select global FSR/ISR/UE parameter set = 'tune' 
2915 C...See routine PYTUNE for details
2916       IF (MSTP(5).NE.0) THEN
2917         MSTP5=MSTP(5)
2918         CALL PYTUNE(MSTP5)
2919       ENDIF
2920 
2921 C...Call user process initialization routine.
2922       IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2923         MSEL=0
2924         CALL UPINIT
2925         MSEL=0
2926       ENDIF
2927  
2928 C...Maximum 4 generations; set maximum number of allowed flavours.
2929       MSTP(1)=MIN(4,MSTP(1))
2930       MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2931       MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2932  
2933 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2934       DO 120 I=-20,20
2935         VINT(180+I)=0D0
2936         IA=IABS(I)
2937         IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2938           DO 110 J=1,MSTP(1)
2939             IB=2*J-1+MOD(IA,2)
2940             IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2941             IPM=(5-ISIGN(1,I))/2
2942             IDC=J+MDCY(IA,2)+2
2943             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2944      &      VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2945   110     CONTINUE
2946         ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2947           VINT(180+I)=1D0
2948         ENDIF
2949   120 CONTINUE
2950  
2951 C...Initialize parton distributions: PDFLIB.
2952       IF(MSTP(52).EQ.2) THEN
2953         PARM(1)='NPTYPE'
2954         VALUE(1)=1
2955         PARM(2)='NGROUP'
2956         VALUE(2)=MSTP(51)/1000
2957         PARM(3)='NSET'
2958         VALUE(3)=MOD(MSTP(51),1000)
2959         PARM(4)='TMAS'
2960         VALUE(4)=PMAS(6,1)
2961         CALL PDFSET(PARM,VALUE)
2962         MINT(93)=1000000+MSTP(51)
2963       ENDIF
2964  
2965 C...Choose Lambda value to use in alpha-strong.
2966       MSTU(111)=MSTP(2)
2967       IF(MSTP(3).GE.2) THEN
2968         ALAM=0.2D0
2969         NF=4
2970         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2971           ALAM=ALAMIN(MSTP(51))
2972           NF=NFIN(MSTP(51))
2973         ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2974           ALAM=QCDL5
2975           NF=5
2976         ELSEIF(MSTP(52).EQ.2) THEN
2977           ALAM=QCDL4
2978           NF=4
2979         ENDIF
2980         PARP(1)=ALAM
2981         PARP(61)=ALAM
2982         PARP(72)=ALAM
2983         PARU(112)=ALAM
2984         MSTU(112)=NF
2985         IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2986       ENDIF
2987  
2988 C...Initialize the UED masses and widths
2989       IF (IUED(1).EQ.1) CALL PYXDIN
2990 
2991 C...Initialize the SUSY generation: couplings, masses,
2992 C...decay modes, branching ratios, and so on.
2993       CALL PYMSIN
2994 C...Initialize widths and partial widths for resonances.
2995       CALL PYINRE
2996 C...Set Z0 mass and width for e+e- routines.
2997       PARJ(123)=PMAS(23,1)
2998       PARJ(124)=PMAS(23,2)
2999  
3000 C...Identify beam and target particles and frame of process.
3001       CHFRAM=FRAME//' '
3002       CHBEAM=BEAM//' '
3003       CHTARG=TARGET//' '
3004       CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3005       IF(MINT(65).EQ.1) GOTO 170
3006  
3007 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3008 C...For e-gamma allow 2 alternatives.
3009       MINT(121)=1
3010       IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3011         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3012      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3013         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3014         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015      &  (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3016       ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3017         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3018      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3019         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3020       ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3021         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3022      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3023         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3024       ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3025         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3026      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3027         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3028       ENDIF
3029       MINT(123)=MSTP(14)
3030       IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3031      &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3032       IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3033         IF(MSTP(14).EQ.11) MINT(123)=0
3034         IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3035         IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3036         IF(MSTP(14).EQ.15) MINT(123)=2
3037         IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3038         IF(MSTP(14).EQ.19) MINT(123)=3
3039       ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3040         IF(MSTP(14).EQ.21) MINT(123)=0
3041         IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3042         IF(MSTP(14).EQ.24) MINT(123)=1
3043       ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3044         IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3045         IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3046       ENDIF
3047  
3048 C...Set up kinematics of process.
3049       CALL PYINKI(0)
3050  
3051 C...Set up kinematics for photons inside leptons.
3052       IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3053  
3054 C...Precalculate flavour selection weights.
3055       CALL PYKFIN
3056  
3057 C...Loop over gamma-p or gamma-gamma alternatives.
3058       CKIN3=CKIN(3)
3059       MSAV48=0
3060       DO 160 IGA=1,MINT(121)
3061         CKIN(3)=CKIN3
3062         MINT(122)=IGA
3063  
3064 C...Select partonic subprocesses to be included in the simulation.
3065         CALL PYINPR
3066         MINT(101)=1
3067         MINT(102)=1
3068         MINT(103)=MINT(11)
3069         MINT(104)=MINT(12)
3070  
3071 C...Count number of subprocesses on.
3072         MINT(48)=0
3073         DO 130 ISUB=1,500
3074           IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3075      &    MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3076             MSUB(ISUB)=0
3077           ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3078      &    MSUB(ISUB).EQ.1) THEN
3079             WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3080             CALL PYSTOP(1)
3081           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3082             WRITE(MSTU(11),5300) ISUB
3083             CALL PYSTOP(1)
3084           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3085             WRITE(MSTU(11),5400) ISUB
3086             CALL PYSTOP(1)
3087           ELSEIF(MSUB(ISUB).EQ.1) THEN
3088             MINT(48)=MINT(48)+1
3089           ENDIF
3090   130   CONTINUE
3091  
3092 C...Stop or raise warning flag if no subprocesses on.
3093         IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3094           IF(MSTP(127).NE.1) THEN
3095             WRITE(MSTU(11),5500)
3096             CALL PYSTOP(1)
3097           ELSE
3098             WRITE(MSTU(11),5700)
3099             MSTI(53)=1
3100           ENDIF
3101         ENDIF
3102         MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3103         MSAV48=MSAV48+MINT(48)
3104  
3105 C...Reset variables for cross-section calculation.
3106         DO 150 I=0,500
3107           DO 140 J=1,3
3108             NGEN(I,J)=0
3109             XSEC(I,J)=0D0
3110   140     CONTINUE
3111   150   CONTINUE
3112  
3113 C...Find parametrized total cross-sections.
3114         CALL PYXTOT
3115         VINT(318)=VINT(317)
3116  
3117 C...Maxima of differential cross-sections.
3118         IF(MSTP(121).LE.1) CALL PYMAXI
3119  
3120 C...Initialize possibility of pileup events.
3121         IF(MINT(121).GT.1) MSTP(131)=0
3122         IF(MSTP(131).NE.0) CALL PYPILE(1)
3123  
3124 C...Initialize multiple interactions with variable impact parameter.
3125         IF(MINT(50).EQ.1) THEN
3126           PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3127           IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3128      &    ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3129           IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3130             MINT(35)=1
3131             CALL PYMULT(1)
3132             MINT(35)=3
3133             CALL PYMIGN(1)
3134           ENDIF
3135         ENDIF
3136  
3137 C...Save results for gamma-p and gamma-gamma alternatives.
3138         IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3139   160 CONTINUE
3140  
3141 C...Initialization finished.
3142       IF(MSAV48.EQ.0) THEN
3143         IF(MSTP(127).NE.1) THEN
3144           WRITE(MSTU(11),5500)
3145           CALL PYSTOP(1)
3146         ELSE
3147           WRITE(MSTU(11),5700)
3148           MSTI(53)=1
3149         ENDIF
3150       ENDIF
3151   170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3152  
3153 C...Formats for initialization information.
3154  5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3155      &'routines',1X,17('*'))
3156  5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3157      &'-',A6,' interactions.'/1X,'Execution stopped!')
3158  5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3159      &1X,'Execution stopped!')
3160  5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3161      &1X,'Execution stopped!')
3162  5500 FORMAT(1X,'Error: no subprocess switched on.'/
3163      &1X,'Execution stopped.')
3164  5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3165      &22('*'))
3166  5700 FORMAT(1X,'Error: no subprocess switched on.'/
3167      &1X,'Execution will stop if you try to generate events.')
3168  
3169       RETURN
3170       END
3171  
3172 C*********************************************************************
3173  
3174 C...PYEVNT
3175 C...Administers the generation of a high-pT event via calls to
3176 C...a number of subroutines.
3177  
3178       SUBROUTINE PYEVNT
3179  
3180 C...Double precision and integer declarations.
3181       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3182       IMPLICIT INTEGER(I-N)
3183       INTEGER PYK,PYCHGE,PYCOMP
3184       PARAMETER (MAXNUR=1000)
3185 C...Commonblocks.
3186       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3187       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3188       COMMON/PYCTAG/NCT,MCT(4000,2)
3189       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3190       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3191       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3192       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3193       COMMON/PYINT1/MINT(400),VINT(400)
3194       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3195       COMMON/PYINT4/MWID(500),WIDS(500,5)
3196       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3197       SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3198      &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3199 C...Local array.
3200       DIMENSION VTX(4)
3201  
3202 C...Optionally let PYEVNW do the whole job.
3203       IF(MSTP(81).GE.20) THEN
3204         CALL PYEVNW
3205         RETURN
3206       ENDIF
3207  
3208 C...Stop if no subprocesses on.
3209       IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3210         WRITE(MSTU(11),5100)
3211         CALL PYSTOP(1)
3212       ENDIF
3213  
3214 C...Initial values for some counters.
3215       MSTU(1)=0
3216       MSTU(2)=0
3217       N=0
3218       MINT(5)=MINT(5)+1
3219       MINT(7)=0
3220       MINT(8)=0
3221       MINT(30)=0
3222       MINT(83)=0
3223       MINT(84)=MSTP(126)
3224       MSTU(24)=0
3225       MSTU70=0
3226       MSTJ14=MSTJ(14)
3227 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3228       NCT=0
3229       MINT(33)=0
3230  
3231 C...Let called routines know call is from PYEVNT (not PYEVNW).
3232       MINT(35)=1
3233       IF (MSTP(81).GE.10) MINT(35)=2
3234  
3235 C...If variable energies: redo incoming kinematics and cross-section.
3236       MSTI(61)=0
3237       IF(MSTP(171).EQ.1) THEN
3238         CALL PYINKI(1)
3239         IF(MSTI(61).EQ.1) THEN
3240           MINT(5)=MINT(5)-1
3241           RETURN
3242         ENDIF
3243         IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3244         CALL PYXTOT
3245       ENDIF
3246  
3247 C...Loop over number of pileup events; check space left.
3248       IF(MSTP(131).LE.0) THEN
3249         NPILE=1
3250       ELSE
3251         CALL PYPILE(2)
3252         NPILE=MINT(81)
3253       ENDIF
3254       DO 270 IPILE=1,NPILE
3255         IF(MINT(84)+100.GE.MSTU(4)) THEN
3256           CALL PYERRM(11,
3257      &    '(PYEVNT:) no more space in PYJETS for pileup events')
3258           IF(MSTU(21).GE.1) GOTO 280
3259         ENDIF
3260         MINT(82)=IPILE
3261  
3262 C...Generate variables of hard scattering.
3263         MINT(51)=0
3264         MSTI(52)=0
3265   100   CONTINUE
3266         IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3267         MINT(31)=0
3268         MINT(39)=0
3269         MINT(51)=0
3270         MINT(57)=0
3271         CALL PYRAND
3272         IF(MSTI(61).EQ.1) THEN
3273           MINT(5)=MINT(5)-1
3274           RETURN
3275         ENDIF
3276         IF(MINT(51).EQ.2) RETURN
3277         ISUB=MINT(1)
3278         IF(MSTP(111).EQ.-1) GOTO 260
3279  
3280 C...Loopback point if PYPREP fails, especially for junction topologies.
3281         NPREP=0
3282         MNT31S=MINT(31)
3283   110   NPREP=NPREP+1
3284         MINT(31)=MNT31S
3285  
3286         IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3287 C...Hard scattering (including low-pT):
3288 C...reconstruct kinematics and colour flow of hard scattering.
3289           MINT31=MINT(31)
3290   120     MINT(31)=MINT31
3291           MINT(51)=0
3292           CALL PYSCAT
3293           IF(MINT(51).EQ.1) GOTO 100
3294           IPU1=MINT(84)+1
3295           IPU2=MINT(84)+2
3296           IF(ISUB.EQ.95) GOTO 140
3297  
3298 C...Reset statistics on activity in event.
3299         DO 130 J=351,359
3300           MINT(J)=0
3301           VINT(J)=0D0
3302   130   CONTINUE
3303  
3304 C...Showering of initial state partons (optional).
3305           NFIN=N
3306           ALAMSV=PARJ(81)
3307           PARJ(81)=PARP(72)
3308           IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3309      &    CALL PYSSPA(IPU1,IPU2)
3310           PARJ(81)=ALAMSV
3311           IF(MINT(51).EQ.1) GOTO 100
3312 
3313 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3314           IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3315             PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3316             CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3317           ENDIF
3318  
3319 C...Showering of final state partons (optional).
3320           ALAMSV=PARJ(81)
3321           PARJ(81)=PARP(72)
3322           IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3323      &    THEN
3324             IPU3=MINT(84)+3
3325             IPU4=MINT(84)+4
3326             IF(ISET(ISUB).EQ.5) IPU4=-3
3327             QMAX=VINT(55)
3328             IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3329             CALL PYSHOW(IPU3,IPU4,QMAX)
3330           ELSEIF(ISET(ISUB).EQ.11) THEN
3331             CALL PYADSH(NFIN)
3332           ENDIF
3333           PARJ(81)=ALAMSV
3334  
3335 C...Allow possibility for user to abort event generation.
3336           IVETO=0
3337           IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3338           IF(IVETO.EQ.1) GOTO 100
3339  
3340 C...Decay of final state resonances.
3341           MINT(32)=0
3342           IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3343           IF(MINT(51).EQ.1) GOTO 100
3344           MINT(52)=N
3345  
3346  
3347 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3348   140     IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3349             IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3350             CALL PYMIGN(6)
3351             IF(MINT(51).EQ.1) GOTO 100
3352             MINT(53)=N
3353  
3354 C...Beam remnant flavour and colour assignments - new scheme.
3355             CALL PYMIHK
3356             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3357      &      GOTO 120
3358             IF(MINT(51).EQ.1) GOTO 100
3359  
3360 C...Primordial kT and beam remnant momentum sharing - new scheme.
3361             CALL PYMIRM
3362             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3363      &      GOTO 120
3364             IF(MINT(51).EQ.1) GOTO 100
3365             IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3366  
3367 C...Multiple interactions - PYTHIA 6.2 style.
3368           ELSEIF(MINT(111).NE.12) THEN
3369             IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3370               CALL PYMULT(6)
3371               MINT(53)=N
3372             ENDIF
3373  
3374 C...Hadron remnants and primordial kT.
3375             CALL PYREMN(IPU1,IPU2)
3376             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3377      &           110
3378             IF(MINT(51).EQ.1) GOTO 100
3379           ENDIF
3380  
3381         ELSEIF(ISUB.NE.99) THEN
3382 C...Diffractive and elastic scattering.
3383           CALL PYDIFF
3384  
3385         ELSE
3386 C...DIS scattering (photon flux external).
3387           CALL PYDISG
3388           IF(MINT(51).EQ.1) GOTO 100
3389         ENDIF
3390  
3391 C...Check that no odd resonance left undecayed.
3392         MINT(54)=N
3393         IF(MSTP(111).GE.1) THEN
3394           NFIX=N
3395           DO 150 I=MINT(84)+1,NFIX
3396             IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3397      &      K(I,2).NE.22) THEN
3398               KCA=PYCOMP(K(I,2))
3399               IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3400                 CALL PYRESD(I)
3401                 IF(MINT(51).EQ.1) GOTO 100
3402               ENDIF
3403             ENDIF
3404   150     CONTINUE
3405         ENDIF
3406  
3407 C...Boost hadronic subsystem to overall rest frame.
3408 C..(Only relevant when photon inside lepton beam.)
3409         IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3410  
3411 C...Recalculate energies from momenta and masses (if desired).
3412         IF(MSTP(113).GE.1) THEN
3413           DO 160 I=MINT(83)+1,N
3414             IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3415      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
3416   160     CONTINUE
3417           NRECAL=N
3418         ENDIF
3419  
3420 C...Colour reconnection before string formation
3421         IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3422 
3423 C...Rearrange partons along strings, check invariant mass cuts.
3424         MSTU(28)=0
3425         IF(MSTP(111).LE.0) MSTJ(14)=-1
3426         CALL PYPREP(MINT(84)+1)
3427         MSTJ(14)=MSTJ14
3428         IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3429           MSTU(24)=0
3430           GOTO 100
3431         ENDIF
3432         IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3433         IF (MINT(51).EQ.1) GOTO 100
3434         IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3435         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3436           DO 190 I=MINT(84)+1,N
3437             IF(K(I,2).EQ.94) THEN
3438               DO 180 I1=I+1,MIN(N,I+10)
3439                 IF(K(I1,3).EQ.I) THEN
3440                   K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3441                   IF(K(I1,3).EQ.0) THEN
3442                     DO 170 II=MINT(84)+1,I-1
3443                         IF(K(II,2).EQ.K(I1,2)) THEN
3444                           IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3445      &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3446                         ENDIF
3447   170               CONTINUE
3448                     IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3449                   ENDIF
3450                 ENDIF
3451   180         CONTINUE
3452             ENDIF
3453   190     CONTINUE
3454           CALL PYEDIT(12)
3455           CALL PYEDIT(14)
3456           IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3457           IF(MSTP(125).EQ.0) MINT(4)=0
3458           DO 210 I=MINT(83)+1,N
3459             IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3460               DO 200 I1=I+1,N
3461                 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3462                 IF(K(I1,3).EQ.I) K(I,5)=I1
3463   200         CONTINUE
3464             ENDIF
3465   210     CONTINUE
3466         ENDIF
3467  
3468 C...Introduce separators between sections in PYLIST event listing.
3469         IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3470           MSTU70=1
3471           MSTU(71)=N
3472         ELSEIF(IPILE.EQ.1) THEN
3473           MSTU70=3
3474           MSTU(71)=2
3475           MSTU(72)=MINT(4)
3476           MSTU(73)=N
3477         ENDIF
3478  
3479 C...Go back to lab frame (needed for vertices, also in fragmentation).
3480         CALL PYFRAM(1)
3481  
3482 C...Set nonvanishing production vertex (optional).
3483         IF(MSTP(151).EQ.1) THEN
3484           DO 220 J=1,4
3485             VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3486      &      SIN(PARU(2)*PYR(0))
3487   220     CONTINUE
3488           DO 240 I=MINT(83)+1,N
3489             DO 230 J=1,4
3490               V(I,J)=V(I,J)+VTX(J)
3491   230       CONTINUE
3492   240     CONTINUE
3493         ENDIF
3494  
3495 C...Perform hadronization (if desired).
3496         IF(MSTP(111).GE.1) THEN
3497           CALL PYEXEC
3498           IF(MSTU(24).NE.0) GOTO 100
3499         ENDIF
3500         IF(MSTP(113).GE.1) THEN
3501           DO 250 I=NRECAL,N
3502             IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3503      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
3504   250     CONTINUE
3505         ENDIF
3506         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3507  
3508 C...Store event information and calculate Monte Carlo estimates of
3509 C...subprocess cross-sections.
3510   260   IF(IPILE.EQ.1) CALL PYDOCU
3511  
3512 C...Set counters for current pileup event and loop to next one.
3513         MSTI(41)=IPILE
3514         IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3515         IF(MSTU70.LT.10) THEN
3516           MSTU70=MSTU70+1
3517           MSTU(70+MSTU70)=N
3518         ENDIF
3519         MINT(83)=N
3520         MINT(84)=N+MSTP(126)
3521         IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3522   270 CONTINUE
3523  
3524 C...Generic information on pileup events. Reconstruct missing history.
3525       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3526         PARI(91)=VINT(132)
3527         PARI(92)=VINT(133)
3528         PARI(93)=VINT(134)
3529         IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3530       ENDIF
3531       CALL PYEDIT(16)
3532  
3533 C...Transform to the desired coordinate frame.
3534   280 CALL PYFRAM(MSTP(124))
3535       MSTU(70)=MSTU70
3536       PARU(21)=VINT(1)
3537  
3538 C...Error messages
3539  5100 FORMAT(1X,'Error: no subprocess switched on.'/
3540      &1X,'Execution stopped.')
3541  
3542       RETURN
3543       END
3544  
3545 C*********************************************************************
3546  
3547 C...PYEVNW
3548 C...Administers the generation of a high-pT event via calls to
3549 C...a number of subroutines for the new multiple interactions and
3550 C...showering framework.
3551  
3552       SUBROUTINE PYEVNW
3553  
3554 C...Double precision and integer declarations.
3555       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3556       IMPLICIT INTEGER(I-N)
3557       INTEGER PYK,PYCHGE,PYCOMP
3558       PARAMETER (MAXNUR=1000)
3559 C...Commonblocks.
3560       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3561 C...Commonblocks.
3562       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3563       COMMON/PYCTAG/NCT,MCT(4000,2)
3564       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3565       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3566       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3567       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3568       COMMON/PYINT1/MINT(400),VINT(400)
3569       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3570       COMMON/PYINT4/MWID(500),WIDS(500,5)
3571       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3572       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3573      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3574      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
3575       SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3576      &     /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3577 C...Local arrays.
3578       DIMENSION VTX(4)
3579  
3580 C...Stop if no subprocesses on.
3581       IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3582         WRITE(MSTU(11),5100)
3583         CALL PYSTOP(1)
3584       ENDIF
3585  
3586 C...Initial values for some counters.
3587       MSTU(1)=0
3588       MSTU(2)=0
3589       N=0
3590       MINT(5)=MINT(5)+1
3591       MINT(7)=0
3592       MINT(8)=0
3593       MINT(30)=0
3594       MINT(83)=0
3595       MINT(84)=MSTP(126)
3596       MSTU(24)=0
3597       MSTU70=0
3598       MSTJ14=MSTJ(14)
3599 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3600       NCT=0
3601       MINT(33)=0
3602 C...Zero counters for pT-ordered showers (failsafe)
3603       NPART=0
3604       NPARTD=0
3605  
3606 C...Let called routines know call is from PYEVNW (not PYEVNT).
3607       MINT(35)=3
3608  
3609 C...If variable energies: redo incoming kinematics and cross-section.
3610       MSTI(61)=0
3611       IF(MSTP(171).EQ.1) THEN
3612         CALL PYINKI(1)
3613         IF(MSTI(61).EQ.1) THEN
3614           MINT(5)=MINT(5)-1
3615           RETURN
3616         ENDIF
3617         IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3618         CALL PYXTOT
3619       ENDIF
3620  
3621 C...Loop over number of pileup events; check space left.
3622       IF(MSTP(131).LE.0) THEN
3623         NPILE=1
3624       ELSE
3625         CALL PYPILE(2)
3626         NPILE=MINT(81)
3627       ENDIF
3628       DO 300 IPILE=1,NPILE
3629         IF(MINT(84)+100.GE.MSTU(4)) THEN
3630           CALL PYERRM(11,
3631      &    '(PYEVNW:) no more space in PYJETS for pileup events')
3632           IF(MSTU(21).GE.1) GOTO 310
3633         ENDIF
3634         MINT(82)=IPILE
3635  
3636 C...Generate variables of hard scattering.
3637         MINT(51)=0
3638         MSTI(52)=0
3639         LOOPHS  =0
3640   100   CONTINUE
3641         LOOPHS  = LOOPHS + 1
3642         IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3643         IF(LOOPHS.GE.10) THEN
3644           CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3645      &        //'multiple interactions. Returning.')
3646           MINT(51)=1
3647           RETURN
3648         ENDIF
3649         MINT(31)=0
3650         MINT(39)=0
3651         MINT(36)=0
3652         MINT(51)=0
3653         MINT(57)=0
3654         CALL PYRAND
3655         IF(MSTI(61).EQ.1) THEN
3656           MINT(5)=MINT(5)-1
3657           RETURN
3658         ENDIF
3659         IF(MINT(51).EQ.2) RETURN
3660         ISUB=MINT(1)
3661         IF(MSTP(111).EQ.-1) GOTO 290
3662  
3663 C...Loopback point if PYPREP fails, especially for junction topologies.
3664         NPREP=0
3665         MNT31S=MINT(31)
3666   110   NPREP=NPREP+1
3667         MINT(31)=MNT31S
3668  
3669         IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3670 C...Hard scattering (including low-pT):
3671 C...reconstruct kinematics and colour flow of hard scattering.
3672           MINT31=MINT(31)
3673   120     MINT(31)=MINT31
3674           MINT(51)=0
3675           CALL PYSCAT
3676           IF(MINT(51).EQ.1) GOTO 100
3677           NPARTD=N
3678           NFIN=N
3679  
3680 C...Intertwined initial state showers and multiple interactions.
3681 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3682 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3683           MSTP61=MSTP(61)
3684           IF (MINT(47).LT.2) MSTP(61)=0
3685           MSTP81=MSTP(81)
3686           IF (MINT(50).EQ.0) MSTP(81)=0
3687           IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3688      &    MINT(111).NE.12) THEN
3689 C...Absolute max pT2 scale for evolution: phase space limit.
3690             PT2MXS=0.25D0*VINT(2)
3691 C...Check if more constrained by ISR and MI max scales:
3692             PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
3693 C...Loopback point in case of failure in evolution.
3694             LOOP=0
3695   130       LOOP=LOOP+1
3696             MINT(51)=0
3697             IF(LOOP.GT.100) THEN
3698               CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3699      &             //'multiple interactions. Trying new point.')
3700               MINT(51)=1
3701               RETURN
3702             ENDIF
3703  
3704 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3705 C...once per event. (E.g. compute constants and save variables to be
3706 C...restored later in case of failure.)
3707             IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3708  
3709 C...Initialize interleaved MI/ISR/JI evolution.
3710 C...PT2MAX: absolute upper limit for evolution - Initialization may
3711 C...        return a PT2MAX which is lower than this.
3712 C...PT2MIN: absolute lower limit for evolution - Initialization may
3713 C...        return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3714             PT2MAX=PT2MXS
3715             PT2MIN=0D0
3716             CALL PYEVOL(0,PT2MAX,PT2MIN)
3717 C...If failed to initialize evolution, generate a new hard process
3718             IF (MINT(51).EQ.1) GOTO 100
3719  
3720 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3721 C...In principle factorized, so can be stopped and restarted.
3722 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3723 C            PT2MED=MAX(10D0**2,PT2MIN)
3724 C            CALL PYEVOL(1,PT2MAX,PT2MED)
3725 C            IF (MINT(51).EQ.1) GOTO 160
3726 C            PT2MAX=PT2MED
3727             CALL PYEVOL(1,PT2MAX,PT2MIN)
3728 C...If fatal error (e.g., massive hard-process initiator, but no available 
3729 C...phase space for creation), generate a new hard process
3730             IF (MINT(51).EQ.2) GOTO 100
3731 C...If smaller error, just try running evolution again
3732             IF (MINT(51).EQ.1) GOTO 130
3733  
3734 C...Finalize interleaved MI/ISR/JI evolution.
3735             CALL PYEVOL(2,PT2MAX,PT2MIN)
3736             IF (MINT(51).EQ.1) GOTO 130
3737  
3738           ENDIF
3739           MSTP(61)=MSTP61
3740           MSTP(81)=MSTP81
3741           IF(MINT(51).EQ.1) GOTO 100
3742 C...(MINT(52) is actually obsolete in this routine. Set anyway
3743 C...to ensure PYDOCU stable.)
3744           MINT(52)=N
3745           MINT(53)=N
3746  
3747 C...Beam remnants - new scheme.
3748   140     IF(MINT(50).EQ.1) THEN
3749             IF (ISUB.EQ.95) MINT(31)=1
3750  
3751 C...Beam remnant flavour and colour assignments - new scheme.
3752             CALL PYMIHK
3753             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3754      &           GOTO 120
3755             IF(MINT(51).EQ.1) GOTO 100
3756  
3757 C...Primordial kT and beam remnant momentum sharing - new scheme.
3758             CALL PYMIRM
3759             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3760      &      GOTO 120
3761             IF(MINT(51).EQ.1) GOTO 100
3762             IF (ISUB.EQ.95) MINT(31)=0
3763           ELSEIF(MINT(111).NE.12) THEN
3764 C...Hadron remnants and primordial kT - old model.
3765 C...Happens e.g. for direct photon on one side.
3766             IPU1=IMI(1,1,1)
3767             IPU2=IMI(2,1,1)
3768             CALL PYREMN(IPU1,IPU2)
3769             IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3770      &           110
3771             IF(MINT(51).EQ.1) GOTO 100
3772 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3773             DO 160 I=MINT(53)+1,N
3774               DO 150 KCS=4,5
3775                 IDA=MOD(K(I,KCS),MSTU(5))
3776                 IF (IDA.NE.0) THEN
3777                   MCT(I,KCS-3)=MCT(IDA,6-KCS)
3778                 ELSE
3779                   MCT(I,KCS-3)=0
3780                 ENDIF
3781   150         CONTINUE
3782   160       CONTINUE
3783 C...Instruct PYPREP to use colour tags
3784             MINT(33)=1
3785 
3786             DO 360 MQGST=1,2
3787               DO 350 I=MINT(84)+1,N
3788   
3789 C...Look for coloured string endpoint, or (later) leftover gluon.
3790                 IF (K(I,1).NE.3) GOTO 350
3791                 KC=PYCOMP(K(I,2))
3792                 IF(KC.EQ.0) GOTO 350
3793                 KQ=KCHG(KC,2)
3794                 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3795   
3796 C...  Pick up loose string end with no previous tag.
3797                 KCS=4
3798                 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3799                 IF(MCT(I,KCS-3).NE.0) GOTO 350
3800                   
3801                 CALL PYCTTR(I,KCS,I)
3802                 IF(MINT(51).NE.0) RETURN
3803   
3804  350          CONTINUE
3805  360        CONTINUE
3806 C...Now delete any colour processing information if set (since partons
3807 C...otherwise not FS showered!)
3808             DO 170 I=MINT(84)+1,N
3809               IF (I.LE.N) THEN
3810                 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3811                 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3812               ENDIF
3813   170       CONTINUE
3814           ENDIF
3815  
3816 C...Showering of final state partons (optional).
3817           ALAMSV=PARJ(81)
3818           PARJ(81)=PARP(72)
3819           IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3820      &    THEN
3821             QMAX=VINT(55)
3822             IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3823             CALL PYPTFS(1,QMAX,0D0,PTGEN)
3824 C...External processes: handle successive showers.
3825           ELSEIF(ISET(ISUB).EQ.11) THEN
3826             CALL PYADSH(NFIN)
3827           ENDIF
3828           PARJ(81)=ALAMSV
3829 
3830 C...Allow possibility for user to abort event generation.
3831           IVETO=0
3832           IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3833           IF(IVETO.EQ.1) THEN
3834 C...........No reason to count this as an error
3835             LOOPHS = LOOPHS-1
3836             GOTO 100
3837           ENDIF
3838 
3839  
3840 C...Decay of final state resonances.
3841           MINT(32)=0
3842           IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3843             CALL PYRESD(0)
3844             IF(MINT(51).NE.0) GOTO 100
3845           ENDIF
3846  
3847           IF(MINT(51).EQ.1) GOTO 100
3848  
3849         ELSEIF(ISUB.NE.99) THEN
3850 C...Diffractive and elastic scattering.
3851           CALL PYDIFF
3852  
3853         ELSE
3854 C...DIS scattering (photon flux external).
3855           CALL PYDISG
3856           IF(MINT(51).EQ.1) GOTO 100
3857         ENDIF
3858  
3859 C...Check that no odd resonance left undecayed.
3860         MINT(54)=N
3861         IF(MSTP(111).GE.1) THEN
3862           NFIX=N
3863           DO 180 I=MINT(84)+1,NFIX
3864             IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3865      &      K(I,2).NE.22) THEN
3866               KCA=PYCOMP(K(I,2))
3867               IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3868                 CALL PYRESD(I)
3869                 IF(MINT(51).EQ.1) GOTO 100
3870               ENDIF
3871             ENDIF
3872   180     CONTINUE
3873         ENDIF
3874  
3875 C...Boost hadronic subsystem to overall rest frame.
3876 C..(Only relevant when photon inside lepton beam.)
3877         IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3878  
3879 C...Recalculate energies from momenta and masses (if desired).
3880         IF(MSTP(113).GE.1) THEN
3881           DO 190 I=MINT(83)+1,N
3882             IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3883      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
3884   190     CONTINUE
3885           NRECAL=N
3886         ENDIF
3887  
3888 C...Colour reconnection before string formation
3889         CALL PYFSCR(MINT(84)+1)
3890  
3891 C...Rearrange partons along strings, check invariant mass cuts.
3892         MSTU(28)=0
3893         IF(MSTP(111).LE.0) MSTJ(14)=-1
3894         CALL PYPREP(MINT(84)+1)
3895         MSTJ(14)=MSTJ14
3896         IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3897           MSTU(24)=0
3898           GOTO 100
3899         ENDIF
3900         IF(MINT(51).EQ.1) GOTO 110
3901         IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3902         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3903           DO 220 I=MINT(84)+1,N
3904             IF(K(I,2).EQ.94) THEN
3905               DO 210 I1=I+1,MIN(N,I+10)
3906                 IF(K(I1,3).EQ.I) THEN
3907                   K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3908                   IF(K(I1,3).EQ.0) THEN
3909                     DO 200 II=MINT(84)+1,I-1
3910                         IF(K(II,2).EQ.K(I1,2)) THEN
3911                           IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3912      &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3913                         ENDIF
3914   200               CONTINUE
3915                     IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3916                   ENDIF
3917                 ENDIF
3918   210         CONTINUE
3919 C...Also collapse particles decaying to themselves (if same KS)
3920 C...Sep 22 2009: Commented out by PS following suggestion by TS to fix 
3921 C...problem with history point-backs in new shower, where a particle is
3922 C...copied with a new momentum when it is the recoiler.
3923 C            ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3924 C     &            .AND.K(I,4).LT.N) THEN
3925 C              IDA=K(I,4)
3926 C              IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3927 C                K(I,1)=0
3928 C              ENDIF
3929             ENDIF
3930   220     CONTINUE
3931           CALL PYEDIT(12)
3932           CALL PYEDIT(14)
3933           IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3934           IF(MSTP(125).EQ.0) MINT(4)=0
3935           DO 240 I=MINT(83)+1,N
3936             IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3937               DO 230 I1=I+1,N
3938                 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3939                 IF(K(I1,3).EQ.I) K(I,5)=I1
3940   230         CONTINUE
3941             ENDIF
3942   240     CONTINUE
3943         ENDIF
3944  
3945 C...Introduce separators between sections in PYLIST event listing.
3946         IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3947           MSTU70=1
3948           MSTU(71)=N
3949         ELSEIF(IPILE.EQ.1) THEN
3950           MSTU70=3
3951           MSTU(71)=2
3952           MSTU(72)=MINT(4)
3953           MSTU(73)=N
3954         ENDIF
3955  
3956 C...Go back to lab frame (needed for vertices, also in fragmentation).
3957         CALL PYFRAM(1)
3958  
3959 C...Set nonvanishing production vertex (optional).
3960         IF(MSTP(151).EQ.1) THEN
3961           DO 250 J=1,4
3962             VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3963      &      SIN(PARU(2)*PYR(0))
3964   250     CONTINUE
3965           DO 270 I=MINT(83)+1,N
3966             DO 260 J=1,4
3967               V(I,J)=V(I,J)+VTX(J)
3968   260       CONTINUE
3969   270     CONTINUE
3970         ENDIF
3971  
3972 C...Perform hadronization (if desired).
3973         IF(MSTP(111).GE.1) THEN
3974           CALL PYEXEC
3975           IF(MSTU(24).NE.0) GOTO 100
3976         ENDIF
3977         IF(MSTP(113).GE.1) THEN
3978           DO 280 I=NRECAL,N
3979             IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3980      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
3981   280     CONTINUE
3982         ENDIF
3983         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3984  
3985 C...Store event information and calculate Monte Carlo estimates of
3986 C...subprocess cross-sections.
3987   290   IF(IPILE.EQ.1) CALL PYDOCU
3988  
3989 C...Set counters for current pileup event and loop to next one.
3990         MSTI(41)=IPILE
3991         IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3992         IF(MSTU70.LT.10) THEN
3993           MSTU70=MSTU70+1
3994           MSTU(70+MSTU70)=N
3995         ENDIF
3996         MINT(83)=N
3997         MINT(84)=N+MSTP(126)
3998         IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3999   300 CONTINUE
4000  
4001 C...Generic information on pileup events. Reconstruct missing history.
4002       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
4003         PARI(91)=VINT(132)
4004         PARI(92)=VINT(133)
4005         PARI(93)=VINT(134)
4006         IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4007       ENDIF
4008       CALL PYEDIT(16)
4009  
4010 C...Transform to the desired coordinate frame.
4011   310 CALL PYFRAM(MSTP(124))
4012       MSTU(70)=MSTU70
4013       PARU(21)=VINT(1)
4014  
4015 C...Error messages
4016  5100 FORMAT(1X,'Error: no subprocess switched on.'/
4017      &1X,'Execution stopped.')
4018  
4019       RETURN
4020       END
4021  
4022  
4023 C***********************************************************************
4024  
4025 C...PYSTAT
4026 C...Prints out information about cross-sections, decay widths, branching
4027 C...ratios, kinematical limits, status codes and parameter values.
4028  
4029       SUBROUTINE PYSTAT(MSTAT)
4030  
4031 C...Double precision and integer declarations.
4032       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4033       IMPLICIT INTEGER(I-N)
4034       INTEGER PYK,PYCHGE,PYCOMP
4035 C...Parameter statement to help give large particle numbers.
4036       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4037      &KEXCIT=4000000,KDIMEN=5000000)
4038       PARAMETER (EPS=1D-3)
4039 C...Commonblocks.
4040       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4041       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4042       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4043       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4044       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4045       COMMON/PYINT1/MINT(400),VINT(400)
4046       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4047       COMMON/PYINT4/MWID(500),WIDS(500,5)
4048       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4049       COMMON/PYINT6/PROC(0:500)
4050       CHARACTER PROC*28, CHTMP*16
4051       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4052       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4053       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4054      &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4055 C...Local arrays, character variables and data.
4056       DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4057       CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4058      &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4059      &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4060       CHARACTER*24 CHD0, CHDC(10)
4061       CHARACTER*6 DNAME(3)
4062       DATA PROGA/
4063      &'VMD/hadron * VMD            ','VMD/hadron * direct         ',
4064      &'VMD/hadron * anomalous      ','direct * direct             ',
4065      &'direct * anomalous          ','anomalous * anomalous       '/
4066       DATA DISGA/'e * VMD','e * anomalous'/
4067       DATA PROGG9/
4068      &'direct * direct             ','direct * VMD                ',
4069      &'direct * anomalous          ','VMD * direct                ',
4070      &'VMD * VMD                   ','VMD * anomalous             ',
4071      &'anomalous * direct          ','anomalous * VMD             ',
4072      &'anomalous * anomalous       ','DIS * VMD                   ',
4073      &'DIS * anomalous             ','VMD * DIS                   ',
4074      &'anomalous * DIS             '/
4075       DATA PROGG4/
4076      &'direct * direct             ','direct * resolved           ',
4077      &'resolved * direct           ','resolved * resolved         '/
4078       DATA PROGG2/
4079      &'direct * hadron             ','resolved * hadron           '/
4080       DATA PROGP4/
4081      &'VMD * hadron                ','direct * hadron             ',
4082      &'anomalous * hadron          ','DIS * hadron                '/
4083       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
4084      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4085      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
4086      &'     y*_small     ','    eta*_large    ','    eta*_small    ',
4087      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
4088      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
4089      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
4090      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
4091      &'       tau''       '/
4092       DATA DNAME /'q     ','lepton','nu    '/
4093  
4094 C...Cross-sections.
4095       IF(MSTAT.LE.1) THEN
4096         IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4097         WRITE(MSTU(11),5000)
4098         WRITE(MSTU(11),5100)
4099         WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4100         DO 100 I=1,500
4101           IF(MSUB(I).NE.1) GOTO 100
4102           WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4103   100   CONTINUE
4104         IF(MINT(121).GT.1) THEN
4105           WRITE(MSTU(11),5300)
4106           DO 110 IGA=1,MINT(121)
4107             CALL PYSAVE(3,IGA)
4108             IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4109               WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4110      &        XSEC(0,3)
4111             ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4112               WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4113      &        XSEC(0,3)
4114             ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4115               WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4116      &        XSEC(0,3)
4117             ELSEIF(MINT(121).EQ.4) THEN
4118               WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4119      &        XSEC(0,3)
4120             ELSEIF(MINT(121).EQ.2) THEN
4121               WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4122      &        XSEC(0,3)
4123             ELSE
4124               WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4125      &        XSEC(0,3)
4126             ENDIF
4127   110     CONTINUE
4128           CALL PYSAVE(5,0)
4129         ENDIF
4130         WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4131      &  1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4132  
4133 C...Decay widths and branching ratios.
4134       ELSEIF(MSTAT.EQ.2) THEN
4135         WRITE(MSTU(11),5500)
4136         WRITE(MSTU(11),5600)
4137         DO 140 KC=1,500
4138           KF=KCHG(KC,4)
4139           CALL PYNAME(KF,CHKF)
4140           IOFF=0
4141           IF(KC.LE.22) THEN
4142             IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4143             IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4144             IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4145             IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4146             IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4147           ELSE
4148             IF(MWID(KC).LE.0) GOTO 140
4149             IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4150      &      KF/KSUSY1.EQ.2)) GOTO 140
4151           ENDIF
4152 C...Off-shell branchings.
4153           IF(IOFF.EQ.1) THEN
4154             NGP=0
4155             IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4156             IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4157      &      PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4158             DO 120 J=1,MDCY(KC,3)
4159               IDC=J+MDCY(KC,2)-1
4160               NGP1=0
4161               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4162      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4163               NGP2=0
4164               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4165      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4166               CALL PYNAME(KFDP(IDC,1),CHD1)
4167               CALL PYNAME(KFDP(IDC,2),CHD2)
4168               IF(KFDP(IDC,3).EQ.0) THEN
4169                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4170      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4171      &          CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4172               ELSE
4173                 CALL PYNAME(KFDP(IDC,3),CHD3)
4174                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4175      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4176      &          CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4177               ENDIF
4178   120       CONTINUE
4179 C...On-shell decays.
4180           ELSE
4181             CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4182             BRFIN=1D0
4183             IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4184             WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4185      &      STATE(MDCY(KC,1)),BRFIN
4186             DO 130 J=1,MDCY(KC,3)
4187               IDC=J+MDCY(KC,2)-1
4188               NGP1=0
4189               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4190      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4191               NGP2=0
4192               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4193      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4194               BRPRI=0D0
4195               IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4196               BRFIN=0D0
4197               IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4198               CALL PYNAME(KFDP(IDC,1),CHD1)
4199               CALL PYNAME(KFDP(IDC,2),CHD2)
4200               IF(KFDP(IDC,3).EQ.0) THEN
4201                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4202      &          WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4203      &          CHD2(1:10),WDTP(J),BRPRI,
4204      &          STATE(MDME(IDC,1)),BRFIN
4205               ELSE
4206                 CALL PYNAME(KFDP(IDC,3),CHD3)
4207                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4208      &          WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4209      &          CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4210      &          STATE(MDME(IDC,1)),BRFIN
4211               ENDIF
4212   130       CONTINUE
4213           ENDIF
4214   140   CONTINUE
4215         WRITE(MSTU(11),6000)
4216  
4217 C...Allowed incoming partons/particles at hard interaction.
4218       ELSEIF(MSTAT.EQ.3) THEN
4219         WRITE(MSTU(11),6100)
4220         CALL PYNAME(MINT(11),CHAU)
4221         CHIN(1)=CHAU(1:12)
4222         CALL PYNAME(MINT(12),CHAU)
4223         CHIN(2)=CHAU(1:12)
4224         WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4225         DO 150 I=-20,22
4226           IF(I.EQ.0) GOTO 150
4227           IA=IABS(I)
4228           IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4229           IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4230           CALL PYNAME(I,CHAU)
4231           WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4232      &    STATE(KFIN(2,I))
4233   150   CONTINUE
4234         WRITE(MSTU(11),6400)
4235  
4236 C...User-defined limits on kinematical variables.
4237       ELSEIF(MSTAT.EQ.4) THEN
4238         WRITE(MSTU(11),6500)
4239         WRITE(MSTU(11),6600)
4240         SHRMAX=CKIN(2)
4241         IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4242         WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4243         PTHMIN=MAX(CKIN(3),CKIN(5))
4244         PTHMAX=CKIN(4)
4245         IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4246         WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4247         WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4248         DO 160 I=4,14
4249           WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4250   160   CONTINUE
4251         SPRMAX=CKIN(32)
4252         IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4253         WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4254         WRITE(MSTU(11),7000)
4255  
4256 C...Status codes and parameter values.
4257       ELSEIF(MSTAT.EQ.5) THEN
4258         WRITE(MSTU(11),7100)
4259         WRITE(MSTU(11),7200)
4260         DO 170 I=1,100
4261           WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4262      &    PARP(100+I)
4263   170   CONTINUE
4264  
4265 C...List of all processes implemented in the program.
4266       ELSEIF(MSTAT.EQ.6) THEN
4267         WRITE(MSTU(11),7400)
4268         WRITE(MSTU(11),7500)
4269         DO 180 I=1,500
4270           IF(ISET(I).LT.0) GOTO 180
4271           WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4272   180   CONTINUE
4273         WRITE(MSTU(11),7700)
4274  
4275       ELSEIF(MSTAT.EQ.7) THEN
4276       WRITE (MSTU(11),8000)
4277       NMODES(0)=0
4278       NMODES(10)=0
4279       NMODES(9)=0
4280       DO 290 ILR=1,2
4281         DO 280 KFSM=1,16
4282           KFSUSY=ILR*KSUSY1+KFSM
4283           NRVDC=0
4284 C...SDOWN DECAYS
4285           IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4286             NRVDC=3
4287             DO 190 I=1,NRVDC
4288               PBRAT(I)=0D0
4289               NMODES(I)=0
4290   190       CONTINUE
4291             CALL PYNAME(KFSUSY,CHTMP)
4292             CHD0=CHTMP//' '
4293             CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4294             CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4295             CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4296             KC=PYCOMP(KFSUSY)
4297             DO 200 J=1,MDCY(KC,3)
4298               IDC=J+MDCY(KC,2)-1
4299               ID1=IABS(KFDP(IDC,1))
4300               ID2=IABS(KFDP(IDC,2))
4301               IF (KFDP(IDC,3).EQ.0) THEN
4302                 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4303      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4304                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
4305                   NMODES(1)=NMODES(1)+1
4306                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4307                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4308                 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4309      &                 .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4310                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
4311                   NMODES(2)=NMODES(2)+1
4312                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4313                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4314                 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4315      &                 .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4316                   PBRAT(3)=PBRAT(3)+BRAT(IDC)
4317                   NMODES(3)=NMODES(3)+1
4318                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4319                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4320                 ENDIF
4321               ENDIF
4322   200       CONTINUE
4323           ENDIF
4324 C...SUP DECAYS
4325           IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4326             NRVDC=2
4327             DO 210 I=1,NRVDC
4328               NMODES(I)=0
4329               PBRAT(I)=0D0
4330   210       CONTINUE
4331             CALL PYNAME(KFSUSY,CHTMP)
4332             CHD0=CHTMP//' '
4333             CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4334             CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4335             KC=PYCOMP(KFSUSY)
4336             DO 220 J=1,MDCY(KC,3)
4337               IDC=J+MDCY(KC,2)-1
4338               ID1=IABS(KFDP(IDC,1))
4339               ID2=IABS(KFDP(IDC,2))
4340               IF (KFDP(IDC,3).EQ.0) THEN
4341                 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4342      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4343                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
4344                   NMODES(1)=NMODES(1)+1
4345                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4346                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4347                 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4348      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4349                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
4350                   NMODES(2)=NMODES(2)+1
4351                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4352                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4353                 ENDIF
4354               ENDIF
4355   220       CONTINUE
4356           ENDIF
4357 C...SLEPTON DECAYS
4358           IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4359             NRVDC=2
4360             DO 230 I=1,NRVDC
4361               PBRAT(I)=0D0
4362               NMODES(I)=0
4363   230       CONTINUE
4364             CALL PYNAME(KFSUSY,CHTMP)
4365             CHD0=CHTMP//' '
4366             CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4367             CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4368             KC=PYCOMP(KFSUSY)
4369             DO 240 J=1,MDCY(KC,3)
4370               IDC=J+MDCY(KC,2)-1
4371               ID1=IABS(KFDP(IDC,1))
4372               ID2=IABS(KFDP(IDC,2))
4373               IF (KFDP(IDC,3).EQ.0) THEN
4374                 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4375      &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4376                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
4377                   NMODES(1)=NMODES(1)+1
4378                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4379                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4380                 ENDIF
4381                 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4382      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4383                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
4384                   NMODES(2)=NMODES(2)+1
4385                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4386                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4387                 ENDIF
4388               ENDIF
4389   240       CONTINUE
4390           ENDIF
4391 C...SNEUTRINO DECAYS
4392           IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4393      &         THEN
4394             NRVDC=2
4395             DO 250 I=1,NRVDC
4396               PBRAT(I)=0D0
4397               NMODES(I)=0
4398   250       CONTINUE
4399             CALL PYNAME(KFSUSY,CHTMP)
4400             CHD0=CHTMP//' '
4401             CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4402             CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4403             KC=PYCOMP(KFSUSY)
4404             DO 260 J=1,MDCY(KC,3)
4405               IDC=J+MDCY(KC,2)-1
4406               ID1=IABS(KFDP(IDC,1))
4407               ID2=IABS(KFDP(IDC,2))
4408               IF (KFDP(IDC,3).EQ.0) THEN
4409                 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4410      &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4411                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
4412                   NMODES(1)=NMODES(1)+1
4413                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4414                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4415                 ENDIF
4416                 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4417      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4418                   NMODES(2)=NMODES(2)+1
4419                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
4420                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4421                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4422                 ENDIF
4423               ENDIF
4424   260       CONTINUE
4425           ENDIF
4426           IF (NRVDC.NE.0) THEN
4427             DO 270 I=1,NRVDC
4428               WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4429               NMODES(0)=NMODES(0)+NMODES(I)
4430   270       CONTINUE
4431           ENDIF
4432   280   CONTINUE
4433   290 CONTINUE
4434       DO 370 KFSM=21,37
4435         KFSUSY=KSUSY1+KFSM
4436         NRVDC=0
4437 C...NEUTRALINO DECAYS
4438         IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4439           NRVDC=4
4440           DO 300 I=1,NRVDC
4441             PBRAT(I)=0D0
4442             NMODES(I)=0
4443   300     CONTINUE
4444           CALL PYNAME(KFSUSY,CHTMP)
4445           CHD0=CHTMP//' '
4446           CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4447           CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4448           CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4449           CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4450           KC=PYCOMP(KFSUSY)
4451           DO 310 J=1,MDCY(KC,3)
4452             IDC=J+MDCY(KC,2)-1
4453             ID1=IABS(KFDP(IDC,1))
4454             ID2=IABS(KFDP(IDC,2))
4455             ID3=IABS(KFDP(IDC,3))
4456             IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4457      &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4458      &           .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4459               PBRAT(1)=PBRAT(1)+BRAT(IDC)
4460               NMODES(1)=NMODES(1)+1
4461               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4462               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4463             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4464      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4465      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4466               PBRAT(2)=PBRAT(2)+BRAT(IDC)
4467               NMODES(2)=NMODES(2)+1
4468               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4469               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4470             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4471      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4472      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4473               PBRAT(3)=PBRAT(3)+BRAT(IDC)
4474               NMODES(3)=NMODES(3)+1
4475               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4476               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4477             ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4478      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4479      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4480               PBRAT(4)=PBRAT(4)+BRAT(IDC)
4481               NMODES(4)=NMODES(4)+1
4482               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4483               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4484             ENDIF
4485   310     CONTINUE
4486         ENDIF
4487 C...CHARGINO DECAYS
4488         IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4489           NRVDC=5
4490           DO 320 I=1,NRVDC
4491             PBRAT(I)=0D0
4492             NMODES(I)=0
4493   320     CONTINUE
4494           CALL PYNAME(KFSUSY,CHTMP)
4495           CHD0=CHTMP//' '
4496           CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4497           CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4498           CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4499           CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4500           CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4501           KC=PYCOMP(KFSUSY)
4502           DO 330 J=1,MDCY(KC,3)
4503             IDC=J+MDCY(KC,2)-1
4504             ID1=IABS(KFDP(IDC,1))
4505             ID2=IABS(KFDP(IDC,2))
4506             ID3=IABS(KFDP(IDC,3))
4507             IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4508      &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4509      &           .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4510               PBRAT(1)=PBRAT(1)+BRAT(IDC)
4511               NMODES(1)=NMODES(1)+1
4512               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4513               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4514             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4515      &             .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4516      &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4517               PBRAT(1)=PBRAT(1)+BRAT(IDC)
4518               NMODES(1)=NMODES(1)+1
4519               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4520               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4521             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4522      &             .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4523      &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4524               PBRAT(2)=PBRAT(2)+BRAT(IDC)
4525               NMODES(2)=NMODES(2)+1
4526               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4527               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4528             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4529      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4530      &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4531               PBRAT(3)=PBRAT(3)+BRAT(IDC)
4532               NMODES(3)=NMODES(3)+1
4533               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4534               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4535             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4536      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4537      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4538               PBRAT(3)=PBRAT(3)+BRAT(IDC)
4539               NMODES(3)=NMODES(3)+1
4540               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4541               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4542             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4543      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4544      &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4545               PBRAT(4)=PBRAT(4)+BRAT(IDC)
4546               NMODES(4)=NMODES(4)+1
4547               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4548               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4549             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4550      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4551      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4552               PBRAT(4)=PBRAT(4)+BRAT(IDC)
4553               NMODES(4)=NMODES(4)+1
4554               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4555               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4556             ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4557      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4558      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4559               PBRAT(5)=PBRAT(5)+BRAT(IDC)
4560               NMODES(5)=NMODES(5)+1
4561               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4562               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4563             ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4564      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4565      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4566               PBRAT(5)=PBRAT(5)+BRAT(IDC)
4567               NMODES(5)=NMODES(5)+1
4568               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4569               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4570             ENDIF
4571   330     CONTINUE
4572         ENDIF
4573 C...GLUINO DECAYS
4574         IF (KFSM.EQ.21) THEN
4575           NRVDC=3
4576           DO 340 I=1,NRVDC
4577             PBRAT(I)=0D0
4578             NMODES(I)=0
4579   340     CONTINUE
4580           CALL PYNAME(KFSUSY,CHTMP)
4581           CHD0=CHTMP//' '
4582           CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4583           CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4584           CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4585           KC=PYCOMP(KFSUSY)
4586           DO 350 J=1,MDCY(KC,3)
4587             IDC=J+MDCY(KC,2)-1
4588             ID1=IABS(KFDP(IDC,1))
4589             ID2=IABS(KFDP(IDC,2))
4590             ID3=IABS(KFDP(IDC,3))
4591             IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4592      &           .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4593      &           .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4594               PBRAT(1)=PBRAT(1)+BRAT(IDC)
4595               NMODES(1)=NMODES(1)+1
4596               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4597               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4598             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4599      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4600      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4601               PBRAT(2)=PBRAT(2)+BRAT(IDC)
4602               NMODES(2)=NMODES(2)+1
4603               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4604               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4605             ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4606      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4607      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4608               PBRAT(3)=PBRAT(3)+BRAT(IDC)
4609               NMODES(3)=NMODES(3)+1
4610               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4611               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4612             ENDIF
4613   350     CONTINUE
4614         ENDIF
4615  
4616         IF (NRVDC.NE.0) THEN
4617           DO 360 I=1,NRVDC
4618             WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4619             NMODES(0)=NMODES(0)+NMODES(I)
4620   360     CONTINUE
4621         ENDIF
4622   370 CONTINUE
4623       WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4624  
4625       IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4626         WRITE (MSTU(11),8500)
4627         DO 400 IRV=1,3
4628           DO 390 JRV=1,3
4629             DO 380 KRV=1,3
4630               WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4631      &             ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4632   380       CONTINUE
4633   390     CONTINUE
4634   400   CONTINUE
4635         WRITE (MSTU(11),8600)
4636       ENDIF
4637       ENDIF
4638  
4639 C...Formats for printouts.
4640  5000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ',
4641      &'Events and Cross-sections',1X,9('*'))
4642  5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4643      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4644      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4645      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4646      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4647      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4648      &'I',12X,'I')
4649  5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4650      &D10.3,1X,'I')
4651  5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4652      &1X,'I',34X,'I',28X,'I',12X,'I')
4653  5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4654      &1X,'********* Total number of errors, excluding junctions =',
4655      &1X,I8,' *************'/
4656      &1X,'********* Total number of errors, including junctions =',
4657      &1X,I8,' *************'/
4658      &1X,'********* Total number of warnings =                   ',
4659      &1X,I8,' *************'/
4660      &1X,'********* Fraction of events that fail fragmentation ',
4661      &'cuts =',1X,F8.5,' *********'/)
4662  5500 FORMAT('1',27('*'),1X,'PYSTAT:  Decay Widths and Branching ',
4663      &'Ratios',1X,27('*'))
4664  5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4665      &1X,'I',5X,'Mother  -->  Branching/Decay Channel',8X,'I',1X,
4666      &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4667      &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4668      &1X,98('='))
4669  5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4670      &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4671      &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4672  5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4673      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4674      &1P,D10.3,0P,1X,'I')
4675  5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4676      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4677      &1P,D10.3,0P,1X,'I')
4678  6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4679  6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4680      &'Particles at Hard Interaction',1X,7('*'))
4681  6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4682      &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4683      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4684      &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4685      &78('=')/1X,'I',38X,'I',37X,'I')
4686  6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4687  6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4688  6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4689      &'Kinematical Variables',1X,12('*'))
4690  6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4691  6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4692      &16X,'I')
4693  6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4694      &1X,'<',1X,1P,D10.3,0P,16X,'I')
4695  6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4696  7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4697  7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4698      &'Parameter Values',1X,12('*'))
4699  7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4700      &'PARP(I)'/)
4701  7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4702  7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4703      &1X,13('*'))
4704  7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4705      &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4706      &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4707  7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4708  7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4709  8000 FORMAT(1X/ 1X/
4710      &     17X,'Sums over R-Violating branching ratios',1X/ 1X
4711      &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4712      &     ,'Mother  -->  Sum over final state flavours',4X,'I',2X
4713      &     ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4714      &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4715  8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4716      &     ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4717      &     1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4718      &     ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4719      &     /1X,70('='))
4720  8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4721      &     'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4722  8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4723  8500 FORMAT(1X/ 1X/
4724      &     1X,'R-Violating couplings',1X/ 1X /
4725      &     1X,55('=')/
4726      &     1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4727      &     ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4728      &     ,'I',15X,'I',15X,'I',15X,'I')
4729  8600 FORMAT(1X,55('='))
4730  8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4731      &     ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4732  
4733       RETURN
4734       END
4735  
4736 C*********************************************************************
4737  
4738 C...PYUPEV
4739 C...Administers the hard-process generation required for output to the
4740 C...Les Houches event record.
4741  
4742       SUBROUTINE PYUPEV
4743  
4744 C...Double precision and integer declarations.
4745       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4746       IMPLICIT INTEGER(I-N)
4747       INTEGER PYK,PYCHGE,PYCOMP
4748  
4749 C...Commonblocks.
4750       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4751       COMMON/PYCTAG/NCT,MCT(4000,2)
4752       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4753       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4754       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4755       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4756       COMMON/PYINT1/MINT(400),VINT(400)
4757       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4758       COMMON/PYINT4/MWID(500),WIDS(500,5)
4759       SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4760      &/PYINT1/,/PYINT2/,/PYINT4/
4761  
4762 C...HEPEUP for output.
4763       INTEGER MAXNUP
4764       PARAMETER (MAXNUP=500)
4765       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4766       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4767       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4768      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4769      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4770       SAVE /HEPEUP/
4771  
4772 C...Stop if no subprocesses on.
4773       IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4774         WRITE(MSTU(11),5100)
4775         STOP
4776       ENDIF
4777 
4778  
4779 C...Special flags for hard-process generation only.
4780       MSTP71=MSTP(71)
4781       MSTP(71)=0
4782       MST128=MSTP(128)
4783       MSTP(128)=1
4784  
4785 C...Initial values for some counters.
4786       N=0
4787       MINT(5)=MINT(5)+1
4788       MINT(7)=0
4789       MINT(8)=0
4790       MINT(30)=0
4791       MINT(83)=0
4792       MINT(84)=MSTP(126)
4793       MSTU(24)=0
4794       MSTU70=0
4795       MSTJ14=MSTJ(14)
4796 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4797       MINT(33)=0
4798  
4799 C...If variable energies: redo incoming kinematics and cross-section.
4800       MSTI(61)=0
4801       IF(MSTP(171).EQ.1) THEN
4802         CALL PYINKI(1)
4803         IF(MSTI(61).EQ.1) THEN
4804           MINT(5)=MINT(5)-1
4805           RETURN
4806         ENDIF
4807         IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4808         CALL PYXTOT
4809       ENDIF
4810  
4811 C...Do not allow pileup events.
4812       MINT(82)=1
4813  
4814 C...Generate variables of hard scattering.
4815       MINT(51)=0
4816       MSTI(52)=0
4817   100 CONTINUE
4818       IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4819       MINT(31)=0
4820       MINT(51)=0
4821       MINT(57)=0
4822       CALL PYRAND
4823       IF(MSTI(61).EQ.1) THEN
4824         MINT(5)=MINT(5)-1
4825         RETURN
4826       ENDIF
4827       IF(MINT(51).EQ.2) RETURN
4828       ISUB=MINT(1)
4829  
4830       IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4831 C...Hard scattering (including low-pT):
4832 C...reconstruct kinematics and colour flow of hard scattering.
4833         MINT31=MINT(31)
4834   110   MINT(31)=MINT31
4835         MINT(51)=0
4836         CALL PYSCAT
4837         IF(MINT(51).EQ.1) GOTO 100
4838         IPU1=MINT(84)+1
4839         IPU2=MINT(84)+2
4840  
4841 C...Decay of final state resonances.
4842         MINT(32)=0
4843         IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4844      &  CALL PYRESD(0)
4845         IF(MINT(51).EQ.1) GOTO 100
4846         MINT(52)=N
4847  
4848 C...Longitudinal boost of hard scattering.
4849         BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4850         CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4851  
4852       ELSEIF(ISUB.NE.99) THEN
4853 C...Diffractive and elastic scattering.
4854         CALL PYDIFF
4855  
4856       ELSE
4857 C...DIS scattering (photon flux external).
4858         CALL PYDISG
4859         IF(MINT(51).EQ.1) GOTO 100
4860       ENDIF
4861  
4862 C...Check that no odd resonance left undecayed.
4863       MINT(54)=N
4864       NFIX=N
4865       DO 120 I=MINT(84)+1,NFIX
4866         IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4867      &  K(I,2).NE.22) THEN
4868           KCA=PYCOMP(K(I,2))
4869           IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4870             CALL PYRESD(I)
4871             IF(MINT(51).EQ.1) GOTO 100
4872           ENDIF
4873         ENDIF
4874   120 CONTINUE
4875 C...Add the option to veto or select certain types of events
4876       IVETO=0
4877       IF(MSTP(143).EQ.1) CALL PYVETO(IVETO)
4878       IF(IVETO.EQ.1) GOTO 100
4879  
4880 C...Boost hadronic subsystem to overall rest frame.
4881 C..(Only relevant when photon inside lepton beam.)
4882       IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4883  
4884 C...Store event information and calculate Monte Carlo estimates of
4885 C...subprocess cross-sections.
4886   130 CALL PYDOCU
4887  
4888 C...Transform to the desired coordinate frame.
4889   140 CALL PYFRAM(MSTP(124))
4890       MSTU(70)=MSTU70
4891       PARU(21)=VINT(1)
4892  
4893 C...Restore special flags for hard-process generation only.
4894       MSTP(71)=MSTP71
4895       MSTP(128)=MST128
4896  
4897 C...Trace colour tags; convert to LHA style labels.
4898       NCT=100
4899       DO 150 I=MINT(84)+1,N
4900         MCT(I,1)=0
4901         MCT(I,2)=0
4902   150 CONTINUE
4903       DO 160 I=MINT(84)+1,N
4904         KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4905         IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4906           IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4907      &    THEN
4908             IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4909             IDA=MOD(K(I,4),MSTU(5))
4910             IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4911      &      MCT(IMO,2).NE.0) THEN
4912               MCT(I,1)=MCT(IMO,2)
4913             ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4914      &      MCT(IMO,1).NE.0) THEN
4915               MCT(I,1)=MCT(IMO,1)
4916             ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4917      &      MCT(IDA,2).NE.0) THEN
4918               MCT(I,1)=MCT(IDA,2)
4919             ELSE
4920               NCT=NCT+1
4921               MCT(I,1)=NCT
4922             ENDIF
4923           ENDIF
4924           IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4925      &    THEN
4926             IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4927             IDA=MOD(K(I,5),MSTU(5))
4928             IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4929      &      MCT(IMO,1).NE.0) THEN
4930               MCT(I,2)=MCT(IMO,1)
4931             ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4932      &      MCT(IMO,2).NE.0) THEN
4933               MCT(I,2)=MCT(IMO,2)
4934             ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4935      &      MCT(IDA,1).NE.0) THEN
4936               MCT(I,2)=MCT(IDA,1)
4937             ELSE
4938               NCT=NCT+1
4939               MCT(I,2)=NCT
4940             ENDIF
4941           ENDIF
4942         ENDIF
4943   160 CONTINUE
4944 C...Error checking
4945       IF(MSTI(52).EQ.0) THEN
4946  
4947 C...Put event in HEPEUP commonblock.
4948       NUP=N-MINT(84)
4949       IDPRUP=MINT(1)
4950       XWGTUP=1D0
4951       SCALUP=VINT(53)
4952       AQEDUP=VINT(57)
4953       AQCDUP=VINT(58)
4954       DO 180 I=1,NUP
4955         IDUP(I)=K(I+MINT(84),2)
4956         IF(I.LE.2) THEN
4957           ISTUP(I)=-1
4958           MOTHUP(1,I)=0
4959           MOTHUP(2,I)=0
4960         ELSEIF(K(I+4,3).EQ.0) THEN
4961           ISTUP(I)=1
4962           MOTHUP(1,I)=1
4963           MOTHUP(2,I)=2
4964         ELSE
4965           ISTUP(I)=1
4966 C...Necessary check for some processes, such as VV->VV
4967           IF(K(I+MINT(84),3)-MINT(84).GT.0) THEN
4968             MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4969             MOTHUP(2,I)=0
4970           ELSE
4971             MOTHUP(1,I)=1
4972             MOTHUP(2,I)=2
4973           ENDIF
4974         ENDIF
4975 C...Check positivity of index for certain cases
4976         IF(I.GE.3.AND.K(I+MINT(84),3)-MINT(84).GT.0) 
4977      $  ISTUP(K(I+MINT(84),3)-MINT(84))=2
4978         ICOLUP(1,I)=MCT(I+MINT(84),1)
4979         ICOLUP(2,I)=MCT(I+MINT(84),2)
4980         DO 170 J=1,5
4981           PUP(J,I)=P(I+MINT(84),J)
4982   170   CONTINUE
4983         VTIMUP(I)=V(I,5)
4984         SPINUP(I)=9D0
4985   180 CONTINUE
4986 
4987       ENDIF
4988 
4989 C...Optionally write out event to disk. Minimal size for time/spin fields.
4990       IF(MSTP(162).GT.0) THEN
4991         WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4992         DO 190 I=1,NUP
4993           IF(VTIMUP(I).EQ.0D0) THEN
4994             WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4995      &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4996      &      ' 0. 9.'
4997           ELSE
4998             WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4999      &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
5000      &      VTIMUP(I),' 9.'
5001           ENDIF
5002   190   CONTINUE
5003 
5004 C...Optional extra line with parton-density information.
5005         IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
5006      &  PARI(33),PARI(34),PARI(23),PARI(29),PARI(30) 
5007       ENDIF
5008  
5009 C...Error messages and other print formats.
5010  5100 FORMAT(1X,'Error: no subprocess switched on.'/
5011      &1X,'Execution stopped.')
5012  5200 FORMAT(1P,2I6,4E14.6)
5013  5300 FORMAT(1P,I8,5I5,5E18.10,A6)
5014  5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
5015  5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
5016  
5017       RETURN
5018       END
5019  
5020 C*********************************************************************
5021  
5022 C...PYUPIN
5023 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5024 C...processes, and optionally stores that information on file.
5025  
5026       SUBROUTINE PYUPIN
5027  
5028 C...Double precision and integer declarations.
5029       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5030       IMPLICIT INTEGER(I-N)
5031  
5032 C...Commonblocks.
5033       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5034       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5035       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5036       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5037       SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5038  
5039 C...User process initialization commonblock.
5040       INTEGER MAXPUP
5041       PARAMETER (MAXPUP=100)
5042       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5043       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5044       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5045      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5046      &LPRUP(MAXPUP)
5047       SAVE /HEPRUP/
5048  
5049 C...Store info on incoming beams.
5050       IDBMUP(1)=K(1,2)
5051       IDBMUP(2)=K(2,2)
5052       EBMUP(1)=P(1,4)
5053       EBMUP(2)=P(2,4)
5054       PDFGUP(1)=0
5055       PDFGUP(2)=0
5056       PDFSUP(1)=MSTP(51)
5057       PDFSUP(2)=MSTP(51)
5058  
5059 C...Event weighting strategy.
5060       IDWTUP=3
5061  
5062 C...Info on individual processes.
5063       NPRUP=0
5064       DO 100 ISUB=1,500
5065         IF(MSUB(ISUB).EQ.1) THEN
5066           NPRUP=NPRUP+1
5067           XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5068           XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5069           XMAXUP(NPRUP)=1D0
5070           LPRUP(NPRUP)=ISUB
5071         ENDIF
5072   100 CONTINUE
5073  
5074 C...Write info to file.
5075       IF(MSTP(161).GT.0) THEN
5076         WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5077      &  PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5078         DO 110 IPR=1,NPRUP
5079           WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5080      &    LPRUP(IPR)
5081   110   CONTINUE
5082       ENDIF
5083  
5084 C...Formats for printout.
5085  5100 FORMAT(1P,2I8,2E14.6,6I6)
5086  5200 FORMAT(1P,3E14.6,I6)
5087  
5088       RETURN
5089       END
5090 
5091 
5092 C*********************************************************************
5093 
5094 C...Combine the two old-style Pythia initialization and event files
5095 C...into a single Les Houches Event File.
5096 
5097       SUBROUTINE PYLHEF
5098  
5099 C...Double precision and integer declarations.
5100       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5101       IMPLICIT INTEGER(I-N)
5102  
5103 C...PYTHIA commonblock: only used to provide read/write units and version.
5104       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5105       SAVE /PYPARS/
5106  
5107 C...User process initialization commonblock.
5108       INTEGER MAXPUP
5109       PARAMETER (MAXPUP=100)
5110       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5111       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5112       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5113      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5114      &LPRUP(MAXPUP)
5115       SAVE /HEPRUP/
5116  
5117 C...User process event common block.
5118       INTEGER MAXNUP
5119       PARAMETER (MAXNUP=500)
5120       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5121       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5122       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5123      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5124      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5125       SAVE /HEPEUP/
5126 
5127 C...Lines to read in assumed never longer than 200 characters. 
5128       PARAMETER (MAXLEN=200)
5129       CHARACTER*(MAXLEN) STRING
5130 
5131 C...Format for reading lines.
5132       CHARACTER*6 STRFMT
5133       STRFMT='(A000)'
5134       WRITE(STRFMT(3:5),'(I3)') MAXLEN
5135 
5136 C...Rewind initialization and event files. 
5137       REWIND MSTP(161)
5138       REWIND MSTP(162)
5139 
5140 C...Write header info.
5141       WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5142       WRITE(MSTP(163),'(A)') '<!--'
5143       WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5144      &MSTP(181),'.',MSTP(182)
5145       WRITE(MSTP(163),'(A)') '-->'       
5146 
5147 C...Read first line of initialization info and get number of processes.
5148       READ(MSTP(161),'(A)',END=400,ERR=400) STRING                  
5149       READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5150      &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5151 
5152 C...Copy initialization lines, omitting trailing blanks. 
5153 C...Embed in <init> ... </init> block.
5154       WRITE(MSTP(163),'(A)') '<init>' 
5155       DO 140 IPR=0,NPRUP
5156         IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5157         LEN=MAXLEN+1  
5158   120   LEN=LEN-1
5159         IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5160         WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5161   140 CONTINUE
5162       WRITE(MSTP(163),'(A)') '</init>' 
5163 
5164 C...Begin event loop. Read first line of event info or already done.
5165       READ(MSTP(162),'(A)',END=320,ERR=400) STRING    
5166   200 CONTINUE
5167 
5168 C...Look at first line to know number of particles in event.
5169       READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5170 
5171 C...Begin an <event> block. Copy event lines, omitting trailing blanks. 
5172       WRITE(MSTP(163),'(A)') '<event>' 
5173       DO 240 I=0,NUP
5174         IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5175         LEN=MAXLEN+1  
5176   220   LEN=LEN-1
5177         IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5178         WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5179   240 CONTINUE
5180               
5181 C...Copy trailing comment lines - with a # in the first column - as is.
5182   260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING    
5183       IF(STRING(1:1).EQ.'#') THEN
5184         LEN=MAXLEN+1  
5185   280   LEN=LEN-1
5186         IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5187         WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5188         GOTO 260
5189       ENDIF
5190 
5191 C..End the <event> block. Loop back to look for next event.
5192       WRITE(MSTP(163),'(A)') '</event>' 
5193       GOTO 200
5194 
5195 C...Successfully reached end of event loop: write closing tag
5196 C...and remove temporary intermediate files (unless asked not to).
5197   300 WRITE(MSTP(163),'(A)') '</event>' 
5198   320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>' 
5199       IF(MSTP(164).EQ.1) RETURN
5200       CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5201       CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5202       RETURN
5203 
5204 C...Error exit.
5205   400 WRITE(*,*) ' PYLHEF file joining failed!'
5206 
5207       RETURN
5208       END
5209  
5210 C*********************************************************************
5211  
5212 C...PYINRE
5213 C...Calculates full and effective widths of gauge bosons, stores
5214 C...masses and widths, rescales coefficients to be used for
5215 C...resonance production generation.
5216  
5217       SUBROUTINE PYINRE
5218  
5219 C...Double precision and integer declarations.
5220       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5221       IMPLICIT INTEGER(I-N)
5222       INTEGER PYK,PYCHGE,PYCOMP
5223 C...Parameter statement to help give large particle numbers.
5224       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5225      &KEXCIT=4000000,KDIMEN=5000000)
5226 C...Commonblocks.
5227       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5228       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5229       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5230       COMMON/PYDAT4/CHAF(500,2)
5231       CHARACTER CHAF*16
5232       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5233       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5234       COMMON/PYINT1/MINT(400),VINT(400)
5235       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5236       COMMON/PYINT4/MWID(500),WIDS(500,5)
5237       COMMON/PYINT6/PROC(0:500)
5238       CHARACTER PROC*28
5239       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5240       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5241      &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5242 C...Local arrays and data.
5243       CHARACTER PRTMP*9
5244       DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5245      &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5246  
5247 C...Born level couplings in MSSM Higgs doublet sector.
5248       XW=PARU(102)
5249       XWV=XW
5250       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5251       XW1=1D0-XW
5252       IF(MSTP(4).EQ.2) THEN
5253         TANBE=PARU(141)
5254         RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5255         SQMZ=PMAS(23,1)**2
5256         SQMW=PMAS(24,1)**2
5257         SQMH=PMAS(25,1)**2
5258         SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5259         SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5260         SQMHC=SQMA+SQMW
5261         IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5262           WRITE(MSTU(11),5000)
5263           CALL PYSTOP(101)
5264         ENDIF
5265         PMAS(35,1)=SQRT(SQMHP)
5266         PMAS(36,1)=SQRT(SQMA)
5267         PMAS(37,1)=SQRT(SQMHC)
5268         ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5269      &  (SQMA-SQMZ)))
5270         BESU=ATAN(TANBE)
5271         PARU(142)=1D0
5272         PARU(143)=1D0
5273         PARU(161)=-SIN(ALSU)/COS(BESU)
5274         PARU(162)=COS(ALSU)/SIN(BESU)
5275         PARU(163)=PARU(161)
5276         PARU(164)=SIN(BESU-ALSU)
5277         PARU(165)=PARU(164)
5278         PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5279         PARU(171)=COS(ALSU)/COS(BESU)
5280         PARU(172)=SIN(ALSU)/SIN(BESU)
5281         PARU(173)=PARU(171)
5282         PARU(174)=COS(BESU-ALSU)
5283         PARU(175)=PARU(174)
5284         PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5285      &  SIN(BESU+ALSU)
5286         PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5287         PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5288         PARU(181)=TANBE
5289         PARU(182)=1D0/TANBE
5290         PARU(183)=PARU(181)
5291         PARU(184)=0D0
5292         PARU(185)=PARU(184)
5293         PARU(186)=COS(BESU-ALSU)
5294         PARU(187)=SIN(BESU-ALSU)
5295         PARU(188)=PARU(186)
5296         PARU(189)=PARU(187)
5297         PARU(190)=0D0
5298         PARU(195)=COS(BESU-ALSU)
5299       ENDIF
5300  
5301 C...Reset effective widths of gauge bosons.
5302       DO 110 I=1,500
5303         DO 100 J=1,5
5304           WIDS(I,J)=1D0
5305   100   CONTINUE
5306   110 CONTINUE
5307  
5308 C...Order resonances by increasing mass (except Z0 and W+/-).
5309       NRES=0
5310       DO 140 KC=1,500
5311         KF=KCHG(KC,4)
5312         IF(KF.EQ.0) GOTO 140
5313         IF(MWID(KC).EQ.0) GOTO 140
5314         IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5315           IF(MSTP(1).LE.3) GOTO 140
5316         ENDIF
5317         IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5318           IF(IMSS(1).LE.0) GOTO 140
5319         ENDIF
5320         NRES=NRES+1
5321         PMRES=PMAS(KC,1)
5322         IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5323         DO 120 I1=NRES-1,1,-1
5324           IF(PMRES.GE.PMORD(I1)) GOTO 130
5325           KCORD(I1+1)=KCORD(I1)
5326           PMORD(I1+1)=PMORD(I1)
5327   120   CONTINUE
5328   130   KCORD(I1+1)=KC
5329         PMORD(I1+1)=PMRES
5330   140 CONTINUE
5331  
5332 C...Loop over possible resonances.
5333       DO 180 I=1,NRES
5334         KC=KCORD(I)
5335         KF=KCHG(KC,4)
5336  
5337 C...Check that no fourth generation channels on by mistake.
5338         IF(MSTP(1).LE.3) THEN
5339           DO 150 J=1,MDCY(KC,3)
5340             IDC=J+MDCY(KC,2)-1
5341             KFA1=IABS(KFDP(IDC,1))
5342             KFA2=IABS(KFDP(IDC,2))
5343             IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5344      &      KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5345      &      MDME(IDC,1)=-1
5346   150     CONTINUE
5347         ENDIF
5348  
5349 C...Check that no supersymmetric channels on by mistake.
5350         IF(IMSS(1).LE.0) THEN
5351           DO 160 J=1,MDCY(KC,3)
5352             IDC=J+MDCY(KC,2)-1
5353             KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5354             KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5355             IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5356      &      MDME(IDC,1)=-1
5357   160     CONTINUE
5358         ENDIF
5359  
5360 C...Find mass and evaluate width.
5361         PMR=PMAS(KC,1)
5362         IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5363         IF(MWID(KC).EQ.3) MINT(63)=1
5364         CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5365         MINT(51)=0
5366  
5367 C...Evaluate suppression factors due to non-simulated channels.
5368         IF(KCHG(KC,3).EQ.0) THEN
5369           WDTP0I=0D0
5370           IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5371           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5372      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5373      &    2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5374           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5375           WIDS(KC,3)=0D0
5376           WIDS(KC,4)=0D0
5377           WIDS(KC,5)=0D0
5378         ELSE
5379           IF(MWID(KC).EQ.3) MINT(63)=1
5380           CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5381           MINT(51)=0
5382           WDTP0I=0D0
5383           IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5384           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5385      &    (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5386      &    (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5387      &    WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5388           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5389           WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5390           WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5391      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5392      &    2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5393           WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5394      &    2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5395      &    2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5396         ENDIF
5397  
5398 C...Set resonance widths and branching ratios;
5399 C...also on/off switch for decays.
5400         IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5401           PMAS(KC,2)=WDTP(0)
5402           PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5403           IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5404           DO 170 J=1,MDCY(KC,3)
5405             IDC=J+MDCY(KC,2)-1
5406             BRAT(IDC)=0D0
5407             IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5408   170     CONTINUE
5409         ENDIF
5410   180 CONTINUE
5411  
5412 C...Flavours of leptoquark: redefine charge and name.
5413       KFLQQ=KFDP(MDCY(42,2),1)
5414       KFLQL=KFDP(MDCY(42,2),2)
5415       KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5416      &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5417       LL=1
5418       IF(IABS(KFLQL).EQ.13) LL=2
5419       IF(IABS(KFLQL).EQ.15) LL=3
5420       CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5421      &CHAF(IABS(KFLQL),1)(1:LL)//' '
5422       CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5423  
5424 C...Special cases in treatment of gamma*/Z0: redefine process name.
5425       IF(MSTP(43).EQ.1) THEN
5426         PROC(1)='f + fbar -> gamma*'
5427         PROC(15)='f + fbar -> g + gamma*'
5428         PROC(19)='f + fbar -> gamma + gamma*'
5429         PROC(30)='f + g -> f + gamma*'
5430         PROC(35)='f + gamma -> f + gamma*'
5431       ELSEIF(MSTP(43).EQ.2) THEN
5432         PROC(1)='f + fbar -> Z0'
5433         PROC(15)='f + fbar -> g + Z0'
5434         PROC(19)='f + fbar -> gamma + Z0'
5435         PROC(30)='f + g -> f + Z0'
5436         PROC(35)='f + gamma -> f + Z0'
5437       ELSEIF(MSTP(43).EQ.3) THEN
5438         PROC(1)='f + fbar -> gamma*/Z0'
5439         PROC(15)='f + fbar -> g + gamma*/Z0'
5440         PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5441         PROC(30)='f + g -> f + gamma*/Z0'
5442         PROC(35)='f + gamma -> f + gamma*/Z0'
5443       ENDIF
5444  
5445 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5446       IF(MSTP(44).EQ.1) THEN
5447         PROC(141)='f + fbar -> gamma*'
5448       ELSEIF(MSTP(44).EQ.2) THEN
5449         PROC(141)='f + fbar -> Z0'
5450       ELSEIF(MSTP(44).EQ.3) THEN
5451         PROC(141)='f + fbar -> Z''0'
5452       ELSEIF(MSTP(44).EQ.4) THEN
5453         PROC(141)='f + fbar -> gamma*/Z0'
5454       ELSEIF(MSTP(44).EQ.5) THEN
5455         PROC(141)='f + fbar -> gamma*/Z''0'
5456       ELSEIF(MSTP(44).EQ.6) THEN
5457         PROC(141)='f + fbar -> Z0/Z''0'
5458       ELSEIF(MSTP(44).EQ.7) THEN
5459         PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5460       ENDIF
5461  
5462 C...Special cases in treatment of WW -> WW: redefine process name.
5463       IF(MSTP(45).EQ.1) THEN
5464         PROC(77)='W+ + W+ -> W+ + W+'
5465       ELSEIF(MSTP(45).EQ.2) THEN
5466         PROC(77)='W+ + W- -> W+ + W-'
5467       ELSEIF(MSTP(45).EQ.3) THEN
5468         PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5469       ENDIF
5470 
5471 C...Initialize Generic Processes
5472       KFGEN=9900001
5473       KCGEN=PYCOMP(KFGEN)
5474       IF(KCGEN.GT.0) THEN
5475         IDCY=MDCY(KCGEN,2)
5476         IF(IDCY.GT.0) THEN
5477           KFF1=KFDP(IDCY+1,1)
5478           KFF2=KFDP(IDCY+1,2)
5479           KCF1=PYCOMP(KFF1)
5480           KCF2=PYCOMP(KFF2)
5481           IJ1=1
5482           IJ2=1
5483           KCI1=PYCOMP(KFDP(IDCY,1))
5484           IF(KFDP(IDCY,1).LT.0) IJ1=2
5485           KCI2=PYCOMP(KFDP(IDCY,2))
5486           IF(KFDP(IDCY,2).LT.0) IJ2=2
5487           ITMP1=0
5488  190      ITMP1=ITMP1+1
5489           IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
5490      &    GOTO 190
5491           ITMP2=0
5492  200      ITMP2=ITMP2+1
5493           IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
5494      &    GOTO 200          
5495           PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
5496           ITMP3=0
5497  205      ITMP3=ITMP3+1
5498           IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
5499      &    GOTO 205
5500           PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
5501           IJ1=1
5502           IJ2=1
5503           IF(KFF1.LT.0) IJ1=2
5504           IF(KFF2.LT.0) IJ2=2
5505           ITMP1=0
5506  210      ITMP1=ITMP1+1
5507           IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
5508      &    GOTO 210
5509           ITMP2=0
5510  220      ITMP2=ITMP2+1
5511           IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
5512      &    GOTO 220          
5513           PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
5514      &    '+'//CHAF(KCF2,IJ2)(1:ITMP2)
5515         ENDIF
5516       ENDIF
5517 
5518 
5519  
5520 C...Format for error information.
5521  5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5522      &'combination'/1X,'Execution stopped!')
5523  
5524       RETURN
5525       END
5526  
5527 C*********************************************************************
5528  
5529 C...PYINBM
5530 C...Identifies the two incoming particles and the choice of frame.
5531  
5532        SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5533  
5534 C...Double precision and integer declarations.
5535       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5536       IMPLICIT INTEGER(I-N)
5537       INTEGER PYK,PYCHGE,PYCOMP
5538  
5539 C...User process initialization commonblock.
5540       INTEGER MAXPUP
5541       PARAMETER (MAXPUP=100)
5542       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5543       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5544       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5545      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5546      &LPRUP(MAXPUP)
5547       SAVE /HEPRUP/
5548  
5549 C...Commonblocks.
5550       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5551       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5552       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5553       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5554       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5555       COMMON/PYINT1/MINT(400),VINT(400)
5556       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5557  
5558 C...Local arrays, character variables and data.
5559       CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5560      &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5561       DIMENSION LEN(3),KCDE(39),PM(2)
5562       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5563      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5564       DATA CHCDE/    'e-          ','e+          ','nu_e        ',
5565      &'nu_ebar     ','mu-         ','mu+         ','nu_mu       ',
5566      &'nu_mubar    ','tau-        ','tau+        ','nu_tau      ',
5567      &'nu_taubar   ','pi+         ','pi-         ','n0          ',
5568      &'nbar0       ','p+          ','pbar-       ','gamma       ',
5569      &'lambda0     ','sigma-      ','sigma0      ','sigma+      ',
5570      &'xi-         ','xi0         ','omega-      ','pi0         ',
5571      &'reggeon     ','pomeron     ','gamma/e-    ','gamma/e+    ',
5572      &'gamma/mu-   ','gamma/mu+   ','gamma/tau-  ','gamma/tau+  ',
5573      &'k+          ','k-          ','ks0         ','kl0         '/
5574       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5575      &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5576      &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5577  
5578 C...Store initial energy. Default frame.
5579       VINT(290)=WIN
5580       MINT(111)=0
5581  
5582 C...Special user process initialization; convert to normal input.
5583       IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5584         MINT(111)=11
5585         IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5586         CALL PYNAME(IDBMUP(1),CHNAME)
5587         CHBEAM=CHNAME(1:12)
5588         CALL PYNAME(IDBMUP(2),CHNAME)
5589         CHTARG=CHNAME(1:12)
5590       ENDIF
5591  
5592 C...Convert character variables to lowercase and find their length.
5593       CHCOM(1)=CHFRAM
5594       CHCOM(2)=CHBEAM
5595       CHCOM(3)=CHTARG
5596       DO 130 I=1,3
5597         LEN(I)=12
5598         DO 110 LL=12,1,-1
5599           IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5600           DO 100 LA=1,26
5601             IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5602      &      CHALP(1)(LA:LA)
5603   100     CONTINUE
5604   110   CONTINUE
5605         CHIDNT(I)=CHCOM(I)
5606  
5607 C...Fix up bar, underscore and charge in particle name (if needed).
5608         DO 120 LL=1,10
5609           IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5610             CHTEMP=CHIDNT(I)
5611             CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//'  '
5612           ENDIF
5613   120   CONTINUE
5614         IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5615           CHTEMP=CHIDNT(I)
5616           CHIDNT(I)='nu_'//CHTEMP(3:7)
5617         ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5618           CHIDNT(I)(1:3)='n0 '
5619         ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5620           CHIDNT(I)(1:5)='nbar0'
5621         ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5622           CHIDNT(I)(1:3)='p+ '
5623         ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5624      &    CHIDNT(I)(1:2).EQ.'p-') THEN
5625           CHIDNT(I)(1:5)='pbar-'
5626         ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5627           CHIDNT(I)(7:7)='0'
5628         ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5629           CHIDNT(I)(1:7)='reggeon'
5630         ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5631           CHIDNT(I)(1:7)='pomeron'
5632         ENDIF
5633   130 CONTINUE
5634  
5635 C...Identify free initialization.
5636       IF(CHCOM(1)(1:2).EQ.'no') THEN
5637         MINT(65)=1
5638         RETURN
5639       ENDIF
5640  
5641 C...Identify incoming beam and target particles.
5642       DO 160 I=1,2
5643         DO 140 J=1,39
5644           IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5645   140   CONTINUE
5646         PM(I)=PYMASS(MINT(10+I))
5647         VINT(2+I)=PM(I)
5648         MINT(140+I)=0
5649         IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5650           CHTEMP=CHIDNT(I+1)(7:12)//' '
5651           DO 150 J=1,12
5652             IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5653   150     CONTINUE
5654           PM(I)=PYMASS(MINT(140+I))
5655           VINT(302+I)=PM(I)
5656         ENDIF
5657   160 CONTINUE
5658       IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5659       IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5660       IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5661  
5662 C...Identify choice of frame and input energies.
5663       CHINIT=' '
5664  
5665 C...Events defined in the CM frame.
5666       IF(CHCOM(1)(1:2).EQ.'cm') THEN
5667         MINT(111)=1
5668         S=WIN**2
5669         IF(MSTP(122).GE.1) THEN
5670           IF(CHCOM(2)(1:1).NE.'e') THEN
5671             LOFFS=(31-(LEN(2)+LEN(3)))/2
5672             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5673      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5674      &      ' collider'//' '
5675           ELSE
5676             LOFFS=(30-(LEN(2)+LEN(3)))/2
5677             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5678      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5679      &      ' collider'//' '
5680           ENDIF
5681           WRITE(MSTU(11),5200) CHINIT
5682           WRITE(MSTU(11),5300) WIN
5683         ENDIF
5684  
5685 C...Events defined in fixed target frame.
5686       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5687         MINT(111)=2
5688         S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5689         IF(MSTP(122).GE.1) THEN
5690           LOFFS=(29-(LEN(2)+LEN(3)))/2
5691           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5692      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5693      &    ' fixed target'//' '
5694           WRITE(MSTU(11),5200) CHINIT
5695           WRITE(MSTU(11),5400) WIN
5696           WRITE(MSTU(11),5500) SQRT(S)
5697         ENDIF
5698  
5699 C...Frame defined by user three-vectors.
5700       ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5701         MINT(111)=3
5702         P(1,5)=PM(1)
5703         P(2,5)=PM(2)
5704         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5705         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5706         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5707      &  (P(1,3)+P(2,3))**2
5708         IF(MSTP(122).GE.1) THEN
5709           LOFFS=(22-(LEN(2)+LEN(3)))/2
5710           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5711      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5712      &    ' user configuration'//' '
5713           WRITE(MSTU(11),5200) CHINIT
5714           WRITE(MSTU(11),5600)
5715           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5716           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5717           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5718         ENDIF
5719  
5720 C...Frame defined by user four-vectors.
5721       ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5722         MINT(111)=4
5723         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5724         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5725         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5726         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5727         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5728      &  (P(1,3)+P(2,3))**2
5729         IF(MSTP(122).GE.1) THEN
5730           LOFFS=(22-(LEN(2)+LEN(3)))/2
5731           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5732      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5733      &    ' user configuration'//' '
5734           WRITE(MSTU(11),5200) CHINIT
5735           WRITE(MSTU(11),5600)
5736           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5737           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5738           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5739         ENDIF
5740  
5741 C...Frame defined by user five-vectors.
5742       ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5743         MINT(111)=5
5744         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5745      &  (P(1,3)+P(2,3))**2
5746         IF(MSTP(122).GE.1) THEN
5747           LOFFS=(22-(LEN(2)+LEN(3)))/2
5748           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5749      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5750      &    ' user configuration'//' '
5751           WRITE(MSTU(11),5200) CHINIT
5752           WRITE(MSTU(11),5600)
5753           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5754           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5755           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5756         ENDIF
5757  
5758 C...Frame defined by HEPRUP common block.
5759       ELSEIF(MINT(111).GE.11) THEN
5760         S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5761      &  SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5762         IF(MSTP(122).GE.1) THEN
5763           LOFFS=(22-(LEN(2)+LEN(3)))/2
5764           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5765      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5766      &    ' user configuration'//' '
5767           WRITE(MSTU(11),5200) CHINIT
5768           WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5769           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5770         ENDIF
5771  
5772 C...Unknown frame. Error for too low CM energy.
5773       ELSE
5774         WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5775         CALL PYSTOP(7)
5776       ENDIF
5777       IF(S.LT.PARP(2)**2) THEN
5778         WRITE(MSTU(11),5900) SQRT(S)
5779         CALL PYSTOP(7)
5780       ENDIF
5781  
5782 C...Formats for initialization and error information.
5783  5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5784      &1X,'Execution stopped!')
5785  5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5786      &1X,'Execution stopped!')
5787  5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5788  5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5789      &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5790  5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5791  5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5792      &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5793  5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5794      &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5795  5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5796  5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5797      &1X,'Execution stopped!')
5798  5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5799      &'generation.'/1X,'Execution stopped!')
5800  6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5801      &'GeV beam energies',13X,'I')
5802  
5803       RETURN
5804       END
5805  
5806 C*********************************************************************
5807  
5808 C...PYINKI
5809 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5810  
5811       SUBROUTINE PYINKI(MODKI)
5812  
5813 C...Double precision and integer declarations.
5814       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5815       IMPLICIT INTEGER(I-N)
5816       INTEGER PYK,PYCHGE,PYCOMP
5817  
5818 C...User process initialization commonblock.
5819       INTEGER MAXPUP
5820       PARAMETER (MAXPUP=100)
5821       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5822       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5823       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5824      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5825      &LPRUP(MAXPUP)
5826       SAVE /HEPRUP/
5827  
5828 C...Commonblocks.
5829       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5830       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5831       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5832       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5833       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5834       COMMON/PYINT1/MINT(400),VINT(400)
5835       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5836  
5837 C...Set initial flavour state.
5838       N=2
5839       DO 100 I=1,2
5840         K(I,1)=1
5841         K(I,2)=MINT(10+I)
5842         IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5843   100 CONTINUE
5844  
5845 C...Reset boost. Do kinematics for various cases.
5846       DO 110 J=6,10
5847         VINT(J)=0D0
5848   110 CONTINUE
5849  
5850 C...Set up kinematics for events defined in CM frame.
5851       IF(MINT(111).EQ.1) THEN
5852         WIN=VINT(290)
5853         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5854         S=WIN**2
5855         P(1,5)=VINT(3)
5856         P(2,5)=VINT(4)
5857         IF(MINT(141).NE.0) P(1,5)=VINT(303)
5858         IF(MINT(142).NE.0) P(2,5)=VINT(304)
5859         P(1,1)=0D0
5860         P(1,2)=0D0
5861         P(2,1)=0D0
5862         P(2,2)=0D0
5863         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5864      &  (4D0*S))
5865         P(2,3)=-P(1,3)
5866         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5867         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5868  
5869 C...Set up kinematics for fixed target events.
5870       ELSEIF(MINT(111).EQ.2) THEN
5871         WIN=VINT(290)
5872         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5873         P(1,5)=VINT(3)
5874         P(2,5)=VINT(4)
5875         IF(MINT(141).NE.0) P(1,5)=VINT(303)
5876         IF(MINT(142).NE.0) P(2,5)=VINT(304)
5877         P(1,1)=0D0
5878         P(1,2)=0D0
5879         P(2,1)=0D0
5880         P(2,2)=0D0
5881         P(1,3)=WIN
5882         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5883         P(2,3)=0D0
5884         P(2,4)=P(2,5)
5885         S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5886         VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5887         CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5888  
5889 C...Set up kinematics for events in user-defined frame.
5890       ELSEIF(MINT(111).EQ.3) THEN
5891         P(1,5)=VINT(3)
5892         P(2,5)=VINT(4)
5893         IF(MINT(141).NE.0) P(1,5)=VINT(303)
5894         IF(MINT(142).NE.0) P(2,5)=VINT(304)
5895         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5896         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5897         DO 120 J=1,3
5898           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5899   120   CONTINUE
5900         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5901         VINT(7)=PYANGL(P(1,1),P(1,2))
5902         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5903         VINT(6)=PYANGL(P(1,3),P(1,1))
5904         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5905         S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5906  
5907 C...Set up kinematics for events with user-defined four-vectors.
5908       ELSEIF(MINT(111).EQ.4) THEN
5909         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5910         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5911         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5912         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5913         DO 130 J=1,3
5914           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5915   130   CONTINUE
5916         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5917         VINT(7)=PYANGL(P(1,1),P(1,2))
5918         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5919         VINT(6)=PYANGL(P(1,3),P(1,1))
5920         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5921         S=(P(1,4)+P(2,4))**2
5922  
5923 C...Set up kinematics for events with user-defined five-vectors.
5924       ELSEIF(MINT(111).EQ.5) THEN
5925         DO 140 J=1,3
5926           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5927   140   CONTINUE
5928         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5929         VINT(7)=PYANGL(P(1,1),P(1,2))
5930         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5931         VINT(6)=PYANGL(P(1,3),P(1,1))
5932         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5933         S=(P(1,4)+P(2,4))**2
5934  
5935 C...Set up kinematics for events with external user processes.
5936       ELSEIF(MINT(111).GE.11) THEN
5937         P(1,5)=VINT(3)
5938         P(2,5)=VINT(4)
5939         IF(MINT(141).NE.0) P(1,5)=VINT(303)
5940         IF(MINT(142).NE.0) P(2,5)=VINT(304)
5941         P(1,1)=0D0
5942         P(1,2)=0D0
5943         P(2,1)=0D0
5944         P(2,2)=0D0
5945         P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5946         P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5947         P(1,4)=EBMUP(1)
5948         P(2,4)=EBMUP(2)
5949         VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5950         CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5951         S=(P(1,4)+P(2,4))**2
5952       ENDIF
5953  
5954 C...Return or error for too low CM energy.
5955       IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5956         IF(MSTP(172).LE.1) THEN
5957           CALL PYERRM(23,
5958      &    '(PYINKI:) too low invariant mass in this event')
5959         ELSE
5960           MSTI(61)=1
5961           RETURN
5962         ENDIF
5963       ENDIF
5964  
5965 C...Save information on incoming particles.
5966       VINT(1)=SQRT(S)
5967       VINT(2)=S
5968       IF(MINT(111).GE.4) THEN
5969         IF(MINT(141).EQ.0) THEN
5970           VINT(3)=P(1,5)
5971           IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5972         ELSE
5973           VINT(303)=P(1,5)
5974         ENDIF
5975         IF(MINT(142).EQ.0) THEN
5976           VINT(4)=P(2,5)
5977           IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5978         ELSE
5979           VINT(304)=P(2,5)
5980         ENDIF
5981       ENDIF
5982       VINT(5)=P(1,3)
5983       IF(MODKI.EQ.0) VINT(289)=S
5984       DO 150 J=1,5
5985         V(1,J)=0D0
5986         V(2,J)=0D0
5987         VINT(290+J)=P(1,J)
5988         VINT(295+J)=P(2,J)
5989   150 CONTINUE
5990  
5991 C...Store pT cut-off and related constants to be used in generation.
5992       IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5993       IF(MSTP(82).LE.1) THEN
5994         PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5995       ELSE
5996         PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5997       ENDIF
5998       VINT(149)=4D0*PTMN**2/S
5999       VINT(154)=PTMN
6000  
6001       RETURN
6002       END
6003  
6004 C*********************************************************************
6005  
6006 C...PYINPR
6007 C...Selects partonic subprocesses to be included in the simulation.
6008  
6009       SUBROUTINE PYINPR
6010  
6011 C...Double precision and integer declarations.
6012       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6013       IMPLICIT INTEGER(I-N)
6014       INTEGER PYK,PYCHGE,PYCOMP
6015  
6016 C...User process initialization commonblock.
6017       INTEGER MAXPUP
6018       PARAMETER (MAXPUP=100)
6019       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6020       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6021       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6022      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
6023      &LPRUP(MAXPUP)
6024       SAVE /HEPRUP/
6025  
6026 C...Commonblocks and character variables.
6027       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6028       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6029       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6030       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6031       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6032       COMMON/PYINT1/MINT(400),VINT(400)
6033       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6034       COMMON/PYINT6/PROC(0:500)
6035       CHARACTER PROC*28
6036       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6037      &/PYINT2/,/PYINT6/
6038       CHARACTER CHIPR*10
6039 
6040  
6041 C...Reset processes to be included.
6042       IF(MSEL.NE.0) THEN
6043         DO 100 I=1,500
6044           MSUB(I)=0
6045   100   CONTINUE
6046       ENDIF
6047  
6048 C...Set running pTmin scale.
6049       IF(MSTP(82).LE.1) THEN
6050         PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6051       ELSE
6052         PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6053       ENDIF
6054  
6055 C...Begin by assuming incoming photon to enter subprocess.
6056       IF(MINT(11).EQ.22) MINT(15)=22
6057       IF(MINT(12).EQ.22) MINT(16)=22
6058  
6059 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
6060       IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
6061         MSUB(10)=1
6062         MINT(123)=MINT(122)+1
6063  
6064 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
6065 C...allow mixture.
6066 C...Here also set a few parameters otherwise normally not touched.
6067       ELSEIF(MINT(121).GT.1) THEN
6068  
6069 C...Parton distributions dampened at small Q2; go to low energies,
6070 C...alpha_s <1; no minimum pT cut-off a priori.
6071         IF(MSTP(18).EQ.2) THEN
6072           MSTP(57)=3
6073           PARP(2)=2D0
6074           PARU(115)=1D0
6075           CKIN(5)=0.2D0
6076           CKIN(6)=0.2D0
6077         ENDIF
6078  
6079 C...Define pT cut-off parameters and whether run involves low-pT.
6080         PTMVMD=PTMRUN
6081         VINT(154)=PTMVMD
6082         PTMDIR=PTMVMD
6083         IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6084         PTMANO=PTMVMD
6085         IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6086      &  0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6087         IPTL=1
6088         IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6089         IF(MSEL.EQ.2) IPTL=1
6090  
6091 C...Set up for p/gamma * gamma; real or virtual photons.
6092         IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6093      &  MSTP(14).EQ.30)) THEN
6094  
6095 C...Set up for p/VMD * VMD.
6096         IF(MINT(122).EQ.1) THEN
6097           MINT(123)=2
6098           MSUB(11)=1
6099           MSUB(12)=1
6100           MSUB(13)=1
6101           MSUB(28)=1
6102           MSUB(53)=1
6103           MSUB(68)=1
6104           IF(IPTL.EQ.1) MSUB(95)=1
6105           IF(MSEL.EQ.2) THEN
6106             MSUB(91)=1
6107             MSUB(92)=1
6108             MSUB(93)=1
6109             MSUB(94)=1
6110           ENDIF
6111           IF(IPTL.EQ.1) CKIN(3)=0D0
6112  
6113 C...Set up for p/VMD * direct gamma.
6114         ELSEIF(MINT(122).EQ.2) THEN
6115           MINT(123)=0
6116           IF(MINT(121).EQ.6) MINT(123)=5
6117           MSUB(131)=1
6118           MSUB(132)=1
6119           MSUB(135)=1
6120           MSUB(136)=1
6121           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6122  
6123 C...Set up for p/VMD * anomalous gamma.
6124         ELSEIF(MINT(122).EQ.3) THEN
6125           MINT(123)=3
6126           IF(MINT(121).EQ.6) MINT(123)=7
6127           MSUB(11)=1
6128           MSUB(12)=1
6129           MSUB(13)=1
6130           MSUB(28)=1
6131           MSUB(53)=1
6132           MSUB(68)=1
6133           IF(IPTL.EQ.1) MSUB(95)=1
6134           IF(MSEL.EQ.2) THEN
6135             MSUB(91)=1
6136             MSUB(92)=1
6137             MSUB(93)=1
6138             MSUB(94)=1
6139           ENDIF
6140           IF(IPTL.EQ.1) CKIN(3)=0D0
6141  
6142 C...Set up for DIS * p.
6143         ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6144      &  IABS(MINT(12)).GT.100)) THEN
6145           MINT(123)=8
6146           IF(IPTL.EQ.1) MSUB(99)=1
6147  
6148 C...Set up for direct * direct gamma (switch off leptons).
6149         ELSEIF(MINT(122).EQ.4) THEN
6150           MINT(123)=0
6151           MSUB(137)=1
6152           MSUB(138)=1
6153           MSUB(139)=1
6154           MSUB(140)=1
6155           DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6156             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6157   110     CONTINUE
6158           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6159  
6160 C...Set up for direct * anomalous gamma.
6161         ELSEIF(MINT(122).EQ.5) THEN
6162           MINT(123)=6
6163           MSUB(131)=1
6164           MSUB(132)=1
6165           MSUB(135)=1
6166           MSUB(136)=1
6167           IF(IPTL.EQ.1) CKIN(3)=PTMANO
6168  
6169 C...Set up for anomalous * anomalous gamma.
6170         ELSEIF(MINT(122).EQ.6) THEN
6171           MINT(123)=3
6172           MSUB(11)=1
6173           MSUB(12)=1
6174           MSUB(13)=1
6175           MSUB(28)=1
6176           MSUB(53)=1
6177           MSUB(68)=1
6178           IF(IPTL.EQ.1) MSUB(95)=1
6179           IF(MSEL.EQ.2) THEN
6180             MSUB(91)=1
6181             MSUB(92)=1
6182             MSUB(93)=1
6183             MSUB(94)=1
6184           ENDIF
6185           IF(IPTL.EQ.1) CKIN(3)=0D0
6186         ENDIF
6187  
6188 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6189         ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6190  
6191 C...Set up for direct * direct gamma (switch off leptons).
6192         IF(MINT(122).EQ.1) THEN
6193           MINT(123)=0
6194           MSUB(137)=1
6195           MSUB(138)=1
6196           MSUB(139)=1
6197           MSUB(140)=1
6198           DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6199             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6200   120     CONTINUE
6201           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6202  
6203 C...Set up for direct * VMD and VMD * direct gamma.
6204         ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6205           MINT(123)=5
6206           MSUB(131)=1
6207           MSUB(132)=1
6208           MSUB(135)=1
6209           MSUB(136)=1
6210           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6211  
6212 C...Set up for direct * anomalous and anomalous * direct gamma.
6213         ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6214           MINT(123)=6
6215           MSUB(131)=1
6216           MSUB(132)=1
6217           MSUB(135)=1
6218           MSUB(136)=1
6219           IF(IPTL.EQ.1) CKIN(3)=PTMANO
6220  
6221 C...Set up for VMD*VMD.
6222         ELSEIF(MINT(122).EQ.5) THEN
6223           MINT(123)=2
6224           MSUB(11)=1
6225           MSUB(12)=1
6226           MSUB(13)=1
6227           MSUB(28)=1
6228           MSUB(53)=1
6229           MSUB(68)=1
6230           IF(IPTL.EQ.1) MSUB(95)=1
6231           IF(MSEL.EQ.2) THEN
6232             MSUB(91)=1
6233             MSUB(92)=1
6234             MSUB(93)=1
6235             MSUB(94)=1
6236           ENDIF
6237           IF(IPTL.EQ.1) CKIN(3)=0D0
6238  
6239 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6240         ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6241           MINT(123)=7
6242           MSUB(11)=1
6243           MSUB(12)=1
6244           MSUB(13)=1
6245           MSUB(28)=1
6246           MSUB(53)=1
6247           MSUB(68)=1
6248           IF(IPTL.EQ.1) MSUB(95)=1
6249           IF(MSEL.EQ.2) THEN
6250             MSUB(91)=1
6251             MSUB(92)=1
6252             MSUB(93)=1
6253             MSUB(94)=1
6254           ENDIF
6255           IF(IPTL.EQ.1) CKIN(3)=0D0
6256  
6257 C...Set up for anomalous * anomalous gamma.
6258         ELSEIF(MINT(122).EQ.9) THEN
6259           MINT(123)=3
6260           MSUB(11)=1
6261           MSUB(12)=1
6262           MSUB(13)=1
6263           MSUB(28)=1
6264           MSUB(53)=1
6265           MSUB(68)=1
6266           IF(IPTL.EQ.1) MSUB(95)=1
6267           IF(MSEL.EQ.2) THEN
6268             MSUB(91)=1
6269             MSUB(92)=1
6270             MSUB(93)=1
6271             MSUB(94)=1
6272           ENDIF
6273           IF(IPTL.EQ.1) CKIN(3)=0D0
6274  
6275 C...Set up for DIS * VMD and VMD * DIS gamma.
6276         ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6277           MINT(123)=8
6278           IF(IPTL.EQ.1) MSUB(99)=1
6279  
6280 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6281         ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6282           MINT(123)=9
6283           IF(IPTL.EQ.1) MSUB(99)=1
6284         ENDIF
6285  
6286 C...Set up for gamma* * p; virtual photons = dir, res.
6287         ELSEIF(MINT(121).EQ.2) THEN
6288  
6289 C...Set up for direct * p.
6290         IF(MINT(122).EQ.1) THEN
6291           MINT(123)=0
6292           MSUB(131)=1
6293           MSUB(132)=1
6294           MSUB(135)=1
6295           MSUB(136)=1
6296           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6297  
6298 C...Set up for resolved * p.
6299         ELSEIF(MINT(122).EQ.2) THEN
6300           MINT(123)=1
6301           MSUB(11)=1
6302           MSUB(12)=1
6303           MSUB(13)=1
6304           MSUB(28)=1
6305           MSUB(53)=1
6306           MSUB(68)=1
6307           IF(IPTL.EQ.1) MSUB(95)=1
6308           IF(MSEL.EQ.2) THEN
6309             MSUB(91)=1
6310             MSUB(92)=1
6311             MSUB(93)=1
6312             MSUB(94)=1
6313           ENDIF
6314           IF(IPTL.EQ.1) CKIN(3)=0D0
6315         ENDIF
6316  
6317 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6318         ELSEIF(MINT(121).EQ.4) THEN
6319  
6320 C...Set up for direct * direct gamma (switch off leptons).
6321         IF(MINT(122).EQ.1) THEN
6322           MINT(123)=0
6323           MSUB(137)=1
6324           MSUB(138)=1
6325           MSUB(139)=1
6326           MSUB(140)=1
6327           DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6328             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6329   130     CONTINUE
6330           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6331  
6332 C...Set up for direct * resolved and resolved * direct gamma.
6333         ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6334           MINT(123)=5
6335           MSUB(131)=1
6336           MSUB(132)=1
6337           MSUB(135)=1
6338           MSUB(136)=1
6339           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6340  
6341 C...Set up for resolved * resolved gamma.
6342         ELSEIF(MINT(122).EQ.4) THEN
6343           MINT(123)=2
6344           MSUB(11)=1
6345           MSUB(12)=1
6346           MSUB(13)=1
6347           MSUB(28)=1
6348           MSUB(53)=1
6349           MSUB(68)=1
6350           IF(IPTL.EQ.1) MSUB(95)=1
6351           IF(MSEL.EQ.2) THEN
6352             MSUB(91)=1
6353             MSUB(92)=1
6354             MSUB(93)=1
6355             MSUB(94)=1
6356           ENDIF
6357           IF(IPTL.EQ.1) CKIN(3)=0D0
6358         ENDIF
6359  
6360 C...End of special set up for gamma-p and gamma-gamma.
6361         ENDIF
6362         CKIN(1)=2D0*CKIN(3)
6363       ENDIF
6364  
6365 C...Flavour information for individual beams.
6366       DO 140 I=1,2
6367         MINT(40+I)=1
6368         IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6369         IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6370         MINT(44+I)=MINT(40+I)
6371         IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6372      &  IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6373   140 CONTINUE
6374  
6375 C...If two real gammas, whereof one direct, pick the first.
6376 C...For two virtual photons, keep requested order.
6377       IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6378         IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6379           MINT(41)=1
6380           MINT(45)=1
6381         ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6382      &  MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6383           MINT(41)=1
6384           MINT(45)=1
6385         ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6386      &  MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6387           MINT(42)=1
6388           MINT(46)=1
6389         ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6390      &  .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6391           MINT(41)=1
6392           MINT(45)=1
6393         ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6394      &  .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6395           MINT(42)=1
6396           MINT(46)=1
6397         ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6398           MINT(41)=1
6399           MINT(45)=1
6400         ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6401           MINT(42)=1
6402           MINT(46)=1
6403         ENDIF
6404       ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6405         IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6406           IF(MINT(11).EQ.22) THEN
6407             MINT(41)=1
6408             MINT(45)=1
6409           ELSE
6410             MINT(42)=1
6411             MINT(46)=1
6412           ENDIF
6413         ENDIF
6414         IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6415      &  '(PYINPR:) unallowed MSTP(14) code for single photon')
6416       ENDIF
6417  
6418 C...Flavour information on combination of incoming particles.
6419       MINT(43)=2*MINT(41)+MINT(42)-2
6420       MINT(44)=MINT(43)
6421       IF(MINT(123).LE.0) THEN
6422         IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6423         IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6424       ELSEIF(MINT(123).LE.3) THEN
6425         IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6426         IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6427       ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6428         MINT(43)=4
6429         MINT(44)=1
6430       ENDIF
6431       MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6432       IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6433       IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6434       IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6435       MINT(50)=0
6436       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6437       MINT(107)=0
6438       MINT(108)=0
6439       IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6440         IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6441      &  MINT(107)=2
6442         IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6443      &  MINT(107)=3
6444         IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6445         IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6446      &  MINT(122).EQ.10) MINT(108)=2
6447         IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6448      &  MINT(122).EQ.11) MINT(108)=3
6449         IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6450       ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6451         IF(MINT(122).GE.3) MINT(107)=1
6452         IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6453       ELSEIF(MINT(121).EQ.2) THEN
6454         IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6455         IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6456       ELSE
6457         IF(MINT(11).EQ.22) THEN
6458           MINT(107)=MINT(123)
6459           IF(MINT(123).GE.4) MINT(107)=0
6460           IF(MINT(123).EQ.7) MINT(107)=2
6461           IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6462           IF(MSTP(14).EQ.28) MINT(107)=2
6463           IF(MSTP(14).EQ.29) MINT(107)=3
6464           IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6465      &    MINT(107)=4
6466         ENDIF
6467         IF(MINT(12).EQ.22) THEN
6468           MINT(108)=MINT(123)
6469           IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6470           IF(MINT(123).EQ.7) MINT(108)=3
6471           IF(MSTP(14).EQ.26) MINT(108)=2
6472           IF(MSTP(14).EQ.27) MINT(108)=3
6473           IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6474           IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6475      &    MINT(108)=4
6476         ENDIF
6477         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6478      &  MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6479           MINTTP=MINT(107)
6480           MINT(107)=MINT(108)
6481           MINT(108)=MINTTP
6482         ENDIF
6483       ENDIF
6484       IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6485       IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6486  
6487 C...Select default processes according to incoming beams
6488 C...(already done for gamma-p and gamma-gamma with
6489 C...MSTP(14) = 10, 20, 25 or 30).
6490       IF(MINT(121).GT.1) THEN
6491       ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6492  
6493         IF(MINT(43).EQ.1) THEN
6494 C...Lepton + lepton -> gamma/Z0 or W.
6495           IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6496           IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6497  
6498         ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6499      &    (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6500 C...Unresolved photon + lepton: Compton scattering.
6501           MSUB(133)=1
6502           MSUB(134)=1
6503  
6504         ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6505      &  .OR.MINT(12).EQ.22)) THEN
6506 C...DIS as pure gamma* + f -> f process.
6507           MSUB(99)=1
6508  
6509         ELSEIF(MINT(43).LE.3) THEN
6510 C...Lepton + hadron: deep inelastic scattering.
6511           MSUB(10)=1
6512  
6513         ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6514      &    MINT(12).EQ.22) THEN
6515 C...Two unresolved photons: fermion pair production,
6516 C...exclude lepton pairs.
6517           DO 150 ISUB=137,140
6518             MSUB(ISUB)=1
6519   150     CONTINUE
6520           DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6521             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6522   160     CONTINUE
6523           PTMDIR=PTMRUN
6524           IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6525           IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6526           CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6527  
6528         ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6529      &    .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6530      &    MINT(12).EQ.22)) THEN
6531 C...Unresolved photon + hadron: photon-parton scattering.
6532           DO 170 ISUB=131,136
6533             MSUB(ISUB)=1
6534   170     CONTINUE
6535  
6536         ELSEIF(MSEL.EQ.1) THEN
6537 C...High-pT QCD processes:
6538           MSUB(11)=1
6539           MSUB(12)=1
6540           MSUB(13)=1
6541           MSUB(28)=1
6542           MSUB(53)=1
6543           MSUB(68)=1
6544           PTMN=PTMRUN
6545           VINT(154)=PTMN
6546           IF(CKIN(3).LT.PTMN) MSUB(95)=1
6547           IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6548  
6549         ELSE
6550 C...All QCD processes:
6551           MSUB(11)=1
6552           MSUB(12)=1
6553           MSUB(13)=1
6554           MSUB(28)=1
6555           MSUB(53)=1
6556           MSUB(68)=1
6557           MSUB(91)=1
6558           MSUB(92)=1
6559           MSUB(93)=1
6560           MSUB(94)=1
6561           MSUB(95)=1
6562         ENDIF
6563  
6564       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6565 C...Heavy quark production.
6566         MSUB(81)=1
6567         MSUB(82)=1
6568         MSUB(84)=1
6569         DO 180 J=1,MIN(8,MDCY(21,3))
6570           MDME(MDCY(21,2)+J-1,1)=0
6571   180   CONTINUE
6572         MDME(MDCY(21,2)+MSEL-1,1)=1
6573         MSUB(85)=1
6574         DO 190 J=1,MIN(12,MDCY(22,3))
6575           MDME(MDCY(22,2)+J-1,1)=0
6576   190   CONTINUE
6577         MDME(MDCY(22,2)+MSEL-1,1)=1
6578  
6579       ELSEIF(MSEL.EQ.10) THEN
6580 C...Prompt photon production:
6581         MSUB(14)=1
6582         MSUB(18)=1
6583         MSUB(29)=1
6584  
6585       ELSEIF(MSEL.EQ.11) THEN
6586 C...Z0/gamma* production:
6587         MSUB(1)=1
6588  
6589       ELSEIF(MSEL.EQ.12) THEN
6590 C...W+/- production:
6591         MSUB(2)=1
6592  
6593       ELSEIF(MSEL.EQ.13) THEN
6594 C...Z0 + jet:
6595         MSUB(15)=1
6596         MSUB(30)=1
6597  
6598       ELSEIF(MSEL.EQ.14) THEN
6599 C...W+/- + jet:
6600         MSUB(16)=1
6601         MSUB(31)=1
6602  
6603       ELSEIF(MSEL.EQ.15) THEN
6604 C...Z0 & W+/- pair production:
6605         MSUB(19)=1
6606         MSUB(20)=1
6607         MSUB(22)=1
6608         MSUB(23)=1
6609         MSUB(25)=1
6610  
6611       ELSEIF(MSEL.EQ.16) THEN
6612 C...h0 production:
6613         MSUB(3)=1
6614         MSUB(102)=1
6615         MSUB(103)=1
6616         MSUB(123)=1
6617         MSUB(124)=1
6618  
6619       ELSEIF(MSEL.EQ.17) THEN
6620 C...h0 & Z0 or W+/- pair production:
6621         MSUB(24)=1
6622         MSUB(26)=1
6623  
6624       ELSEIF(MSEL.EQ.18) THEN
6625 C...h0 production; interesting processes in e+e-.
6626         MSUB(24)=1
6627         MSUB(103)=1
6628         MSUB(123)=1
6629         MSUB(124)=1
6630  
6631       ELSEIF(MSEL.EQ.19) THEN
6632 C...h0, H0 and A0 production; interesting processes in e+e-.
6633         MSUB(24)=1
6634         MSUB(103)=1
6635         MSUB(123)=1
6636         MSUB(124)=1
6637         MSUB(153)=1
6638         MSUB(171)=1
6639         MSUB(173)=1
6640         MSUB(174)=1
6641         MSUB(158)=1
6642         MSUB(176)=1
6643         MSUB(178)=1
6644         MSUB(179)=1
6645  
6646       ELSEIF(MSEL.EQ.21) THEN
6647 C...Z'0 production:
6648         MSUB(141)=1
6649  
6650       ELSEIF(MSEL.EQ.22) THEN
6651 C...W'+/- production:
6652         MSUB(142)=1
6653  
6654       ELSEIF(MSEL.EQ.23) THEN
6655 C...H+/- production:
6656         MSUB(143)=1
6657  
6658       ELSEIF(MSEL.EQ.24) THEN
6659 C...R production:
6660         MSUB(144)=1
6661  
6662       ELSEIF(MSEL.EQ.25) THEN
6663 C...LQ (leptoquark) production.
6664         MSUB(145)=1
6665         MSUB(162)=1
6666         MSUB(163)=1
6667         MSUB(164)=1
6668  
6669       ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6670 C...Production of one heavy quark (W exchange):
6671         MSUB(83)=1
6672         DO 200 J=1,MIN(8,MDCY(21,3))
6673           MDME(MDCY(21,2)+J-1,1)=0
6674   200   CONTINUE
6675         MDME(MDCY(21,2)+MSEL-31,1)=1
6676  
6677 CMRENNA++Define SUSY alternatives.
6678       ELSEIF(MSEL.EQ.39) THEN
6679 C...Turn on all SUSY processes.
6680         IF(MINT(43).EQ.4) THEN
6681 C...Hadron-hadron processes.
6682           DO 210 I=201,296
6683             IF(ISET(I).GE.0) MSUB(I)=1
6684   210     CONTINUE
6685         ELSEIF(MINT(43).EQ.1) THEN
6686 C...Lepton-lepton processes: QED production of squarks.
6687           DO 220 I=201,214
6688             MSUB(I)=1
6689   220     CONTINUE
6690           MSUB(210)=0
6691           MSUB(211)=0
6692           MSUB(212)=0
6693           DO 230 I=216,228
6694             MSUB(I)=1
6695   230     CONTINUE
6696           DO 240 I=261,263
6697             MSUB(I)=1
6698   240     CONTINUE
6699           MSUB(277)=1
6700           MSUB(278)=1
6701         ENDIF
6702  
6703       ELSEIF(MSEL.EQ.40) THEN
6704 C...Gluinos and squarks.
6705         IF(MINT(43).EQ.4) THEN
6706           MSUB(243)=1
6707           MSUB(244)=1
6708           MSUB(258)=1
6709           MSUB(259)=1
6710           MSUB(261)=1
6711           MSUB(262)=1
6712           MSUB(264)=1
6713           MSUB(265)=1
6714           DO 250 I=271,296
6715             MSUB(I)=1
6716   250     CONTINUE
6717         ELSEIF(MINT(43).EQ.1) THEN
6718           MSUB(277)=1
6719           MSUB(278)=1
6720         ENDIF
6721  
6722       ELSEIF(MSEL.EQ.41) THEN
6723 C...Stop production.
6724         MSUB(261)=1
6725         MSUB(262)=1
6726         MSUB(263)=1
6727         IF(MINT(43).EQ.4) THEN
6728           MSUB(264)=1
6729           MSUB(265)=1
6730         ENDIF
6731  
6732       ELSEIF(MSEL.EQ.42) THEN
6733 C...Slepton production.
6734         DO 260 I=201,214
6735           MSUB(I)=1
6736   260   CONTINUE
6737         IF(MINT(43).NE.4) THEN
6738           MSUB(210)=0
6739           MSUB(211)=0
6740           MSUB(212)=0
6741         ENDIF
6742  
6743       ELSEIF(MSEL.EQ.43) THEN
6744 C...Neutralino/Chargino + Gluino/Squark.
6745         IF(MINT(43).EQ.4) THEN
6746           DO 270 I=237,242
6747             MSUB(I)=1
6748   270     CONTINUE
6749           DO 280 I=246,254
6750             MSUB(I)=1
6751   280     CONTINUE
6752           MSUB(256)=1
6753         ENDIF
6754  
6755       ELSEIF(MSEL.EQ.44) THEN
6756 C...Neutralino/Chargino pair production.
6757         IF(MINT(43).EQ.4) THEN
6758           DO 290 I=216,236
6759             MSUB(I)=1
6760   290     CONTINUE
6761         ELSEIF(MINT(43).EQ.1) THEN
6762           DO 300 I=216,228
6763             MSUB(I)=1
6764   300     CONTINUE
6765         ENDIF
6766  
6767       ELSEIF(MSEL.EQ.45) THEN
6768 C...Sbottom production.
6769         MSUB(287)=1
6770         MSUB(288)=1
6771         IF(MINT(43).EQ.4) THEN
6772           DO 310 I=281,296
6773             MSUB(I)=1
6774   310     CONTINUE
6775         ENDIF
6776  
6777       ELSEIF(MSEL.EQ.50) THEN
6778 C...Pair production of technipions and gauge bosons.
6779         DO 320 I=361,368
6780           MSUB(I)=1
6781   320   CONTINUE
6782         IF(MINT(43).EQ.4) THEN
6783           DO 330 I=370,377
6784             MSUB(I)=1
6785   330     CONTINUE
6786         ENDIF
6787  
6788       ELSEIF(MSEL.EQ.51) THEN
6789 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6790         DO 340 I=381,386
6791           MSUB(I)=1
6792   340   CONTINUE
6793  
6794       ELSEIF(MSEL.EQ.61) THEN
6795 C...Charmonium production in colour octet model, with recoiling parton.
6796         DO 342 I=421,439
6797           MSUB(I)=1
6798  342   CONTINUE
6799  
6800       ELSEIF(MSEL.EQ.62) THEN
6801 C...Bottomonium production in colour octet model, with recoiling parton.
6802         DO 344 I=461,479
6803           MSUB(I)=1
6804  344   CONTINUE
6805  
6806       ELSEIF(MSEL.EQ.63) THEN
6807 C...Charmonium and bottomonium production in colour octet model.
6808         DO 346 I=421,439
6809           MSUB(I)=1
6810           MSUB(I+40)=1
6811  346   CONTINUE
6812       ENDIF
6813  
6814 C...Find heaviest new quark flavour allowed in processes 81-84.
6815       KFLQM=1
6816       DO 350 I=1,MIN(8,MDCY(21,3))
6817         IDC=I+MDCY(21,2)-1
6818         IF(MDME(IDC,1).LE.0) GOTO 350
6819         KFLQM=I
6820   350 CONTINUE
6821       IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6822      &KFLQM=MSTP(7)
6823       MINT(55)=KFLQM
6824       KFPR(81,1)=KFLQM
6825       KFPR(81,2)=KFLQM
6826       KFPR(82,1)=KFLQM
6827       KFPR(82,2)=KFLQM
6828       KFPR(83,1)=KFLQM
6829       KFPR(84,1)=KFLQM
6830       KFPR(84,2)=KFLQM
6831  
6832 C...Find heaviest new fermion flavour allowed in process 85.
6833       KFLFM=1
6834       DO 360 I=1,MIN(12,MDCY(22,3))
6835         IDC=I+MDCY(22,2)-1
6836         IF(MDME(IDC,1).LE.0) GOTO 360
6837         KFLFM=KFDP(IDC,1)
6838   360 CONTINUE
6839       IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6840      &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6841       MINT(56)=KFLFM
6842       KFPR(85,1)=KFLFM
6843       KFPR(85,2)=KFLFM
6844 
6845 C...Initialize Generic Processes
6846       KFGEN=9900001
6847       KCGEN=PYCOMP(KFGEN)
6848       IF(KCGEN.GT.0) THEN
6849         IDCY=MDCY(KCGEN,2)
6850         IF(IDCY.GT.0) THEN
6851           KFF1=KFDP(IDCY+1,1)
6852           KFF2=KFDP(IDCY+1,2)
6853           KCF1=PYCOMP(KFF1)
6854           KCF2=PYCOMP(KFF2)
6855           JCOL1=IABS(KCHG(KCF1,2))
6856           IF(JCOL1.EQ.1) THEN
6857             KF1=KFF1
6858             KF2=KFF2
6859           ELSE
6860             KF1=KFF2
6861             KF2=KFF1
6862           ENDIF
6863           KFPR(481,1)=KF1
6864           KFPR(481,2)=KF2
6865           KFPR(482,1)=KF1
6866           KFPR(482,2)=KF2
6867         ENDIF
6868         IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
6869           KFIN(1,0)=1
6870           KFIN(2,0)=1
6871         ENDIF
6872       ENDIF
6873  
6874 C...Import relevant information on external user processes.
6875       IF(MINT(111).GE.11) THEN
6876         IPYPR=0
6877         DO 390 IUP=1,NPRUP
6878 C...Find next empty PYTHIA process number slot and enable it.
6879   370     IPYPR=IPYPR+1
6880           IF(IPYPR.GT.500) CALL PYERRM(26,
6881      &    '(PYINPR.) no more empty slots for user processes')
6882           IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6883           IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6884           ISET(IPYPR)=11
6885 C...Overwrite KFPR with references back to process number and ID.
6886           KFPR(IPYPR,1)=IUP
6887           KFPR(IPYPR,2)=LPRUP(IUP)
6888 C...Process title.
6889           WRITE(CHIPR,'(I10)') LPRUP(IUP)
6890           ICHIN=1
6891           DO 380 ICH=1,9
6892             IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6893   380     CONTINUE
6894           PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6895 C...Switch on process.
6896           MSUB(IPYPR)=1
6897   390   CONTINUE
6898       ENDIF
6899 
6900       RETURN
6901       END
6902  
6903 C*********************************************************************
6904  
6905 C...PYXTOT
6906 C...Parametrizes total, elastic and diffractive cross-sections
6907 C...for different energies and beams. Donnachie-Landshoff for
6908 C...total and Schuler-Sjostrand for elastic and diffractive.
6909 C...Process code IPROC:
6910 C...=  1 : p + p;
6911 C...=  2 : pbar + p;
6912 C...=  3 : pi+ + p;
6913 C...=  4 : pi- + p;
6914 C...=  5 : pi0 + p;
6915 C...=  6 : phi + p;
6916 C...=  7 : J/psi + p;
6917 C...= 11 : rho + rho;
6918 C...= 12 : rho + phi;
6919 C...= 13 : rho + J/psi;
6920 C...= 14 : phi + phi;
6921 C...= 15 : phi + J/psi;
6922 C...= 16 : J/psi + J/psi;
6923 C...= 21 : gamma + p (DL);
6924 C...= 22 : gamma + p (VDM).
6925 C...= 23 : gamma + pi (DL);
6926 C...= 24 : gamma + pi (VDM);
6927 C...= 25 : gamma + gamma (DL);
6928 C...= 26 : gamma + gamma (VDM).
6929  
6930       SUBROUTINE PYXTOT
6931  
6932 C...Double precision and integer declarations.
6933       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6934       IMPLICIT INTEGER(I-N)
6935       INTEGER PYK,PYCHGE,PYCOMP
6936 C...Commonblocks.
6937       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6938       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6939       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6940       COMMON/PYINT1/MINT(400),VINT(400)
6941       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6942       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6943       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6944 C...Local arrays.
6945       DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6946      &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6947      &CEFFD(10,9),SIGTMP(6,0:5)
6948  
6949 C...Common constants.
6950       DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6951      &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6952      &FACDD/0.0084D0/
6953  
6954 C...Number of multiple processes to be evaluated (= 0 : undefined).
6955       DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6956 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6957       DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6958      &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6959      &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6960       DATA YPAR/
6961      &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6962      &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6963      &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6964  
6965 C...Beam and target hadron class:
6966 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6967       DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6968       DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6969 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6970       DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6971       DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6972       DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6973  
6974 C...Fitting constants used in parametrizations of diffractive results.
6975       DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6976       DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6977       DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6978      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6979      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6980      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6981      &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6982      &0.267D0, 0.0D0, -0.46D0,  75D0, 0.267D0, 0.0D0, -0.46D0,  75D0,
6983      &0.232D0, 0.0D0, -0.46D0,  85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6984      &0.115D0, 0.0D0, -0.50D0,  90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6985      &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6986      &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6987      &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6988       DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6989      &3.11D0, -7.34D0,  9.71D0, 0.068D0, -0.42D0,  1.31D0,
6990      &-1.37D0,  35.0D0,  118D0,  3.11D0, -7.10D0,  10.6D0,
6991      &0.073D0, -0.41D0, 1.17D0, -1.41D0,  31.6D0,   95D0,
6992      &3.12D0, -7.43D0,  9.21D0, 0.067D0, -0.44D0,  1.41D0,
6993      &-1.35D0,  36.5D0,  132D0,  3.13D0, -8.18D0, -4.20D0,
6994      &0.056D0, -0.71D0, 3.12D0, -1.12D0,  55.2D0, 1298D0,
6995      &3.11D0, -6.90D0,  11.4D0, 0.078D0, -0.40D0,  1.05D0,
6996      &-1.40D0,  28.4D0,   78D0,  3.11D0, -7.13D0,  10.0D0,
6997      &0.071D0, -0.41D0, 1.23D0, -1.34D0,  33.1D0,  105D0,
6998      &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0,  2.72D0,
6999      &-1.13D0,  53.1D0,  995D0,  3.11D0, -7.39D0,  8.22D0,
7000      &0.065D0, -0.44D0, 1.45D0, -1.36D0,  38.1D0,  148D0,
7001      &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0,  3.32D0,
7002      &-1.12D0,  55.6D0, 1472D0,  4.18D0, -29.2D0,  56.2D0,
7003      &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
7004  
7005 C...Parameters. Combinations of the energy.
7006       AEM=PARU(101)
7007       PMTH=PARP(102)
7008       S=VINT(2)
7009       SRT=VINT(1)
7010       SEPS=S**EPS
7011       SETA=S**ETA
7012       SLOG=LOG(S)
7013  
7014 C...Ratio of gamma/pi (for rescaling in parton distributions).
7015       VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
7016      &(XPAR(5)*SEPS+YPAR(5)*SETA)
7017       VINT(317)=1D0
7018       IF(MINT(50).NE.1) RETURN
7019  
7020 C...Order flavours of incoming particles: KF1 < KF2.
7021       IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
7022         KF1=IABS(MINT(11))
7023         KF2=IABS(MINT(12))
7024         IORD=1
7025       ELSE
7026         KF1=IABS(MINT(12))
7027         KF2=IABS(MINT(11))
7028         IORD=2
7029       ENDIF
7030       ISGN12=ISIGN(1,MINT(11)*MINT(12))
7031  
7032 C...Find process number (for lookup tables).
7033       IF(KF1.GT.1000) THEN
7034         IPROC=1
7035         IF(ISGN12.LT.0) IPROC=2
7036       ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
7037         IPROC=3
7038         IF(ISGN12.LT.0) IPROC=4
7039         IF(KF1.EQ.111) IPROC=5
7040       ELSEIF(KF1.GT.100) THEN
7041         IPROC=11
7042       ELSEIF(KF2.GT.1000) THEN
7043         IPROC=21
7044         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
7045       ELSEIF(KF2.GT.100) THEN
7046         IPROC=23
7047         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
7048       ELSE
7049         IPROC=25
7050         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
7051       ENDIF
7052  
7053 C... Number of multiple processes to be stored; beam/target side.
7054       NPR=NPROC(IPROC)
7055       MINT(101)=1
7056       MINT(102)=1
7057       IF(NPR.EQ.3) THEN
7058         MINT(100+IORD)=4
7059       ELSEIF(NPR.EQ.6) THEN
7060         MINT(101)=4
7061         MINT(102)=4
7062       ENDIF
7063       N1=0
7064       IF(MINT(101).EQ.4) N1=4
7065       N2=0
7066       IF(MINT(102).EQ.4) N2=4
7067  
7068 C...Do not do any more for user-set or undefined cross-sections.
7069       IF(MSTP(31).LE.0) RETURN
7070       IF(NPR.EQ.0) CALL PYERRM(26,
7071      &'(PYXTOT:) cross section for this process not yet implemented')
7072  
7073 C...Parameters. Combinations of the energy.
7074       AEM=PARU(101)
7075       PMTH=PARP(102)
7076       S=VINT(2)
7077       SRT=VINT(1)
7078       SEPS=S**EPS
7079       SETA=S**ETA
7080       SLOG=LOG(S)
7081  
7082 C...Loop over multiple processes (for VDM).
7083       DO 110 I=1,NPR
7084         IF(NPR.EQ.1) THEN
7085           IPR=IPROC
7086         ELSEIF(NPR.EQ.3) THEN
7087           IPR=I+4
7088           IF(KF2.LT.1000) IPR=I+10
7089         ELSEIF(NPR.EQ.6) THEN
7090           IPR=I+10
7091         ENDIF
7092  
7093 C...Evaluate hadron species, mass, slope contribution and fit number.
7094         IHA=IHADA(IPR)
7095         IHB=IHADB(IPR)
7096         PMA=PMHAD(IHA)
7097         PMB=PMHAD(IHB)
7098         BHA=BHAD(IHA)
7099         BHB=BHAD(IHB)
7100         ISD=IFITSD(IPR)
7101         IDD=IFITDD(IPR)
7102  
7103 C...Skip if energy too low relative to masses.
7104         DO 100 J=0,5
7105           SIGTMP(I,J)=0D0
7106   100   CONTINUE
7107         IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7108  
7109 C...Total cross-section. Elastic slope parameter and cross-section.
7110         SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7111         BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7112         SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7113  
7114 C...Diffractive scattering A + B -> X + B.
7115         BSD=2D0*BHB
7116         SQML=(PMA+PMTH)**2
7117         SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7118         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7119      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7120         BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7121         SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7122      &  (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7123         SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7124  
7125 C...Diffractive scattering A + B -> A + X.
7126         BSD=2D0*BHA
7127         SQML=(PMB+PMTH)**2
7128         SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7129         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7130      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7131         BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7132         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7133      &  (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7134         SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7135  
7136 C...Order single diffractive correctly.
7137         IF(IORD.EQ.2) THEN
7138           SIGSAV=SIGTMP(I,2)
7139           SIGTMP(I,2)=SIGTMP(I,3)
7140           SIGTMP(I,3)=SIGSAV
7141         ENDIF
7142  
7143 C...Double diffractive scattering A + B -> X1 + X2.
7144         YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7145         DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7146         SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7147         IF(YEFF.LE.0) SUM1=0D0
7148         SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7149         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7150         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7151         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7152      &  (2D0*ALP)
7153         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7154         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7155         SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7156      &  (2D0*ALP)
7157         BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7158         SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7159         SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7160      &  LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7161         SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7162  
7163 C...Non-diffractive by unitarity.
7164         SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7165      &  SIGTMP(I,4)
7166   110 CONTINUE
7167  
7168 C...Put temporary results in output array: only one process.
7169       IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7170         DO 120 J=0,5
7171           SIGT(0,0,J)=SIGTMP(1,J)
7172   120   CONTINUE
7173  
7174 C...Beam multiple processes.
7175       ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7176         IF(MINT(107).EQ.2) THEN
7177           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7178         ELSE
7179           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7180      &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7181         ENDIF
7182         IF(MSTP(20).GT.0) THEN
7183           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7184         ENDIF
7185         DO 140 I=1,4
7186           IF(MINT(107).EQ.2) THEN
7187             CONV=(AEM/PARP(160+I))*VINT(317)
7188           ELSEIF(VINT(154).GT.PARP(15)) THEN
7189             CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7190      &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7191           ELSE
7192             CONV=0D0
7193           ENDIF
7194           I1=MAX(1,I-1)
7195           DO 130 J=0,5
7196             SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7197   130     CONTINUE
7198   140   CONTINUE
7199         DO 150 J=0,5
7200           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7201   150   CONTINUE
7202  
7203 C...Target multiple processes.
7204       ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7205         IF(MINT(108).EQ.2) THEN
7206           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7207         ELSE
7208           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7209      &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7210         ENDIF
7211         IF(MSTP(20).GT.0) THEN
7212           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7213         ENDIF
7214         DO 170 I=1,4
7215           IF(MINT(108).EQ.2) THEN
7216             CONV=(AEM/PARP(160+I))*VINT(317)
7217           ELSEIF(VINT(154).GT.PARP(15)) THEN
7218             CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7219      &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7220           ELSE
7221             CONV=0D0
7222           ENDIF
7223           IV=MAX(1,I-1)
7224           DO 160 J=0,5
7225             SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7226   160     CONTINUE
7227   170   CONTINUE
7228         DO 180 J=0,5
7229           SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7230   180   CONTINUE
7231  
7232 C...Both beam and target multiple processes.
7233       ELSE
7234         IF(MINT(107).EQ.2) THEN
7235           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7236         ELSE
7237           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7238      &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7239         ENDIF
7240         IF(MINT(108).EQ.2) THEN
7241           VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7242         ELSE
7243           VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7244      &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7245         ENDIF
7246         IF(MSTP(20).GT.0) THEN
7247           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7248      &    VINT(308)))**MSTP(20)
7249         ENDIF
7250         DO 210 I1=1,4
7251           DO 200 I2=1,4
7252             IF(MINT(107).EQ.2) THEN
7253               CONV=(AEM/PARP(160+I1))*VINT(317)
7254             ELSEIF(VINT(154).GT.PARP(15)) THEN
7255               CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7256      &        (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7257             ELSE
7258               CONV=0D0
7259             ENDIF
7260             IF(MINT(108).EQ.2) THEN
7261               CONV=CONV*(AEM/PARP(160+I2))
7262             ELSEIF(VINT(154).GT.PARP(15)) THEN
7263               CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7264      &        (1D0/PARP(15)**2-1D0/VINT(154)**2)
7265             ELSE
7266               CONV=0D0
7267             ENDIF
7268             IF(I1.LE.2) THEN
7269               IV=MAX(1,I2-1)
7270             ELSEIF(I2.LE.2) THEN
7271               IV=MAX(1,I1-1)
7272             ELSEIF(I1.EQ.I2) THEN
7273               IV=2*I1-2
7274             ELSE
7275               IV=5
7276             ENDIF
7277             DO 190 J=0,5
7278               JV=J
7279               IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7280               SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7281   190       CONTINUE
7282   200     CONTINUE
7283   210   CONTINUE
7284         DO 230 J=0,5
7285           DO 220 I=1,4
7286             SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7287             SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7288   220     CONTINUE
7289           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7290   230   CONTINUE
7291       ENDIF
7292  
7293 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7294       IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7295         RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7296         DO 260 I1=0,N1
7297           DO 250 I2=0,N2
7298             DO 240 J=0,5
7299               SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7300   240       CONTINUE
7301   250     CONTINUE
7302   260   CONTINUE
7303       ENDIF
7304  
7305       RETURN
7306       END
7307  
7308 C*********************************************************************
7309  
7310 C...PYMAXI
7311 C...Finds optimal set of coefficients for kinematical variable selection
7312 C...and the maximum of the part of the differential cross-section used
7313 C...in the event weighting.
7314  
7315       SUBROUTINE PYMAXI
7316  
7317 C...Double precision and integer declarations.
7318       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7319       IMPLICIT INTEGER(I-N)
7320       INTEGER PYK,PYCHGE,PYCOMP
7321 C...Parameter statement to help give large particle numbers.
7322       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7323      &KEXCIT=4000000,KDIMEN=5000000)
7324  
7325 C...User process initialization commonblock.
7326       INTEGER MAXPUP
7327       PARAMETER (MAXPUP=100)
7328       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7329       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7330       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7331      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7332      &LPRUP(MAXPUP)
7333       SAVE /HEPRUP/
7334  
7335 C...Commonblocks.
7336       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7337       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7338       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7339       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7340       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7341       COMMON/PYINT1/MINT(400),VINT(400)
7342       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7343       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7344       COMMON/PYINT4/MWID(500),WIDS(500,5)
7345       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7346       COMMON/PYINT6/PROC(0:500)
7347       CHARACTER PROC*28
7348       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7349       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7350       COMMON/PYTCCO/COEFX(194:380,2)
7351       COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7352       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7353      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7354      &/PYTCSM/,/TCPARA/
7355 C...Local arrays, character variables and data.
7356       LOGICAL IOK
7357       CHARACTER CVAR(4)*4
7358       DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7359      &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7360      &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7361      &IQ(9),IP(9)
7362       DATA CVAR/'tau ','tau''','y*  ','cth '/
7363       DATA SIGSSM/3*0D0/
7364  
7365 C...Initial values and loop over subprocesses.
7366       NPOSI=0
7367       VINT(143)=1D0
7368       VINT(144)=1D0
7369       XSEC(0,1)=0D0
7370       ITECH=0
7371       DO 460 ISUB=1,500
7372         MINT(1)=ISUB
7373         MINT(51)=0
7374  
7375 C...Find maximum weight factors for photon flux.
7376         IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7377           IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7378         ENDIF
7379  
7380 C...Select subprocess to study: skip cases not applicable.
7381         IF(ISET(ISUB).EQ.11) THEN
7382           IF(MSUB(ISUB).NE.1) GOTO 460
7383 C...User process intialization: cross section model dependent.
7384           IF(IABS(IDWTUP).EQ.1) THEN
7385             IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7386      &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7387             XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7388           ELSE
7389             IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7390      &      XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7391      &      PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7392             IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7393      &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7394             XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7395           ENDIF
7396           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7397      &    WTGAGA*XSEC(ISUB,1)
7398           NPOSI=NPOSI+1
7399           GOTO 450
7400         ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7401           CALL PYSIGH(NCHN,SIGS)
7402           XSEC(ISUB,1)=SIGS
7403           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7404      &    WTGAGA*XSEC(ISUB,1)
7405           IF(MSUB(ISUB).NE.1) GOTO 460
7406           NPOSI=NPOSI+1
7407           GOTO 450
7408         ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7409           CALL PYSIGH(NCHN,SIGS)
7410           XSEC(ISUB,1)=SIGS
7411           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7412      &    WTGAGA*XSEC(ISUB,1)
7413           IF(XSEC(ISUB,1).EQ.0D0) THEN
7414             MSUB(ISUB)=0
7415           ELSE
7416             NPOSI=NPOSI+1
7417           ENDIF
7418           GOTO 450
7419         ELSEIF(ISUB.EQ.96) THEN
7420           IF(MINT(50).EQ.0) GOTO 460
7421           IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7422      &    GOTO 460
7423           IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7424         ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7425      &    ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7426           IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7427         ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7428           IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7429         ELSE
7430           IF(MSUB(ISUB).NE.1) GOTO 460
7431         ENDIF
7432         ISTSB=ISET(ISUB)
7433         IF(ISUB.EQ.96) ISTSB=2
7434         IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7435         MWTXS=0
7436         IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7437      &  MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7438  
7439 C...Find resonances (explicit or implicit in cross-section).
7440         MINT(72)=0
7441         KFR1=0
7442         IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7443           KFR1=KFPR(ISUB,1)
7444         ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7445      &    .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7446           KFR1=23
7447         ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7448      &    .OR.ISUB.EQ.177) THEN
7449           KFR1=24
7450         ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7451           KFR1=25
7452           IF(MSTP(46).EQ.5) THEN
7453             KFR1=89
7454             PMAS(89,1)=PARP(45)
7455             PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7456           ENDIF
7457         ELSEIF(ISUB.EQ.481) THEN
7458           KFR1=9900001
7459         ENDIF
7460         CKMX=CKIN(2)
7461         IF(CKMX.LE.0D0) CKMX=VINT(1)
7462         KCR1=PYCOMP(KFR1)
7463         IF(KCR1.EQ.0) KFR1=0
7464         IF(KFR1.NE.0) THEN
7465           IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7466      &    CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7467         ENDIF
7468         IF(KFR1.NE.0) THEN
7469           TAUR1=PMAS(KCR1,1)**2/VINT(2)
7470           GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7471           MINT(72)=1
7472           MINT(73)=KFR1
7473           VINT(73)=TAUR1
7474           VINT(74)=GAMR1
7475         ENDIF
7476         KFR2=0
7477         KFR3=0
7478         IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7479      $  (ISUB.GE.361.AND.ISUB.LE.380))
7480      $  THEN
7481           KFR2=23
7482           IF(ISUB.EQ.141) THEN
7483             KCR2=PYCOMP(KFR2)
7484             IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7485      &       CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7486               KFR2=0
7487             ELSE
7488               TAUR2=PMAS(KCR2,1)**2/VINT(2)            
7489               GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7490               MINT(72)=2
7491               MINT(74)=KFR2
7492               VINT(75)=TAUR2
7493               VINT(76)=GAMR2
7494             ENDIF
7495           ELSEIF(ITECH.EQ.0) THEN
7496             ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7497             ITECH=1
7498             KFR1=KTECHN+113              
7499             KCR1=PYCOMP(KFR1)
7500             KFR2=KTECHN+223
7501             KCR2=PYCOMP(KFR2)
7502             KFR3=KTECHN+115
7503             KCR3=PYCOMP(KFR3)
7504             IRES=0
7505 C...Order the resonances
7506             IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7507               KCT=KCR3
7508               KCR3=KCR2
7509               KCR2=KCT
7510             ENDIF
7511             IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7512               KCT=KCR3
7513               KCR3=KCR1
7514               KCR1=KCT
7515             ENDIF
7516             IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7517               KCT=KCR2
7518               KCR2=KCR1
7519               KCR1=KCT
7520             ENDIF
7521             DO 101 I=1,3
7522               IF(I.EQ.1) THEN
7523                 SHN0=PMAS(KCR1,1)**2
7524               ELSEIF(I.EQ.2) THEN
7525                 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7526                 SHN0=PMAS(KCR2,1)**2
7527               ELSEIF(I.EQ.3) THEN
7528                 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7529                 SHN0=PMAS(KCR3,1)**2
7530               ENDIF
7531               AEM=PYALEM(SHN0)
7532               FAR=SQRT(AEM/ALPRHT)              
7533               SHN=SHN0*(1D0-FAR)
7534               CALL PYTECM(SHN,S1,WIDO,1)
7535               RES=SHN-S1
7536               SHN=S1*.99D0
7537               SHSTEP=2D0
7538  102          SHN=SHN+SHSTEP
7539               CALL PYTECM(SHN,S1,WIDO,1)
7540               IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7541                 IOK=.FALSE.
7542                 IF(IRES.GT.0) THEN
7543                   IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7544                 ELSEIF(IRES.EQ.0) THEN
7545                   IOK=.TRUE.
7546                 ENDIF
7547                 IF(IOK) THEN
7548                   IRES=IRES+1
7549                   XMAS(IRES)=SQRT(S1)
7550                   XWID(IRES)=WIDO
7551                 ENDIF
7552               ENDIF
7553               RES=SHN-S1
7554               IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7555  101        CONTINUE
7556             JRES=0
7557             KFR1=KTECHN+213              
7558             KCR1=PYCOMP(KFR1)
7559             KFR2=KTECHN+215
7560             KCR2=PYCOMP(KFR2)
7561             IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7562               KCT=KCR2
7563               KCR2=KCR1
7564               KCR1=KCT
7565             ENDIF
7566             DO 103 I=1,2
7567               IF(I.EQ.1) THEN
7568                 SHN0=PMAS(KCR1,1)**2
7569               ELSEIF(I.EQ.2) THEN
7570                 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7571                 SHN0=PMAS(KCR2,1)**2
7572               ENDIF
7573               AEM=PYALEM(SHN0)
7574               FAR=SQRT(AEM/ALPRHT)              
7575               SHN=SHN0*(1D0-FAR)
7576               CALL PYTECM(SHN,S1,WIDO,2)
7577               RES=SHN-S1
7578               SHN=S1*.99D0
7579               SHSTEP=2D0
7580  104          SHN=SHN+SHSTEP
7581               CALL PYTECM(SHN,S1,WIDO,2)
7582               IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7583                 IOK=.FALSE.
7584                 IF(JRES.GT.0) THEN
7585                   IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7586                 ELSEIF(JRES.EQ.0) THEN
7587                   IOK=.TRUE.
7588                 ENDIF
7589                 IF(IOK) THEN
7590                   JRES=JRES+1
7591                   YMAS(JRES)=SQRT(S1)
7592                   YWID(JRES)=WIDO
7593                 ENDIF
7594               ENDIF
7595               RES=SHN-S1
7596               IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7597  103        CONTINUE
7598           ENDIF
7599           IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7600      &     ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7601             MINT(72)=IRES
7602             IF(IRES.GE.1) THEN
7603               VINT(73)=XMAS(1)**2/VINT(2)
7604               VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7605               TAUR1=VINT(73)
7606               GAMR1=VINT(74)
7607               XM1=XMAS(1)
7608               XG1=XWID(1)
7609               KFR1=1
7610             ENDIF
7611             IF(IRES.GE.2) THEN
7612               VINT(75)=XMAS(2)**2/VINT(2)
7613               VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7614               TAUR2=VINT(75)
7615               GAMR2=VINT(76)
7616               XM2=XMAS(2)
7617               XG2=XWID(2)
7618               KFR2=2
7619             ENDIF
7620             IF(IRES.EQ.3) THEN
7621               VINT(77)=XMAS(3)**2/VINT(2)
7622               VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7623               TAUR3=VINT(77)
7624               GAMR3=VINT(78)
7625               XM3=XMAS(3)
7626               XG3=XWID(3)
7627               KFR3=3
7628             ENDIF
7629 C...Charged current:  rho+- and a+-
7630           ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7631             MINT(72)=IRES
7632             IF(JRES.GE.1) THEN
7633               VINT(73)=YMAS(1)**2/VINT(2)
7634               VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7635               KFR1=1
7636               TAUR1=VINT(73)
7637               GAMR1=VINT(74)
7638               XM1=YMAS(1)
7639               XG1=YWID(1)
7640             ENDIF
7641             IF(JRES.GE.2) THEN
7642               VINT(75)=YMAS(2)**2/VINT(2)
7643               VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7644               KFR2=2
7645               TAUR2=VINT(73)
7646               GAMR2=VINT(74)
7647               XM2=YMAS(2)
7648               XG2=YWID(2)
7649             ENDIF
7650             KFR3=0
7651           ENDIF
7652           IF(ISUB.NE.141) THEN
7653             IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7654      &       .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7655             IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7656      &       .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7657             IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7658      &       .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7659             IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7660 
7661             ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7662               MINT(72)=2
7663             ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7664               MINT(72)=2
7665               MINT(74)=KFR3
7666               VINT(75)=TAUR3
7667               VINT(76)=GAMR3
7668             ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7669               MINT(72)=2
7670               MINT(73)=KFR2
7671               VINT(73)=TAUR2
7672               VINT(74)=GAMR2
7673               MINT(74)=KFR3
7674               VINT(75)=TAUR3
7675               VINT(76)=GAMR3
7676             ELSEIF(KFR1.NE.0) THEN
7677               MINT(72)=1
7678             ELSEIF(KFR2.NE.0) THEN
7679               MINT(72)=1
7680               MINT(73)=KFR2
7681               VINT(73)=TAUR2
7682               VINT(74)=GAMR2
7683             ELSEIF(KFR3.NE.0) THEN
7684               MINT(72)=1
7685               MINT(73)=KFR3
7686               VINT(73)=TAUR3
7687               VINT(74)=GAMR3
7688             ELSE
7689               MINT(72)=0
7690             ENDIF
7691           ELSE
7692             IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7693 
7694             ELSEIF(KFR2.NE.0) THEN
7695               KFR1=KFR2
7696               TAUR1=TAUR2
7697               GAMR1=GAMR2
7698               MINT(72)=1
7699               MINT(73)=KFR1
7700               VINT(73)=TAUR1
7701               VINT(74)=GAMR1
7702               KFR2=0
7703             ELSE
7704               MINT(72)=0
7705             ENDIF
7706           ENDIF
7707         ENDIF
7708  
7709 C...Find product masses and minimum pT of process.
7710         SQM3=0D0
7711         SQM4=0D0
7712         MINT(71)=0
7713         VINT(71)=CKIN(3)
7714         VINT(80)=1D0
7715         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7716           NBW=0
7717           DO 110 I=1,2
7718             PMMN(I)=0D0
7719             IF(KFPR(ISUB,I).EQ.0) THEN
7720             ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7721      &        PARP(41)) THEN
7722               IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7723               IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7724             ELSE
7725               NBW=NBW+1
7726 C...This prevents SUSY/t particles from becoming too light.
7727               KFLW=KFPR(ISUB,I)
7728               IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7729                 KCW=PYCOMP(KFLW)
7730                 PMMN(I)=PMAS(KCW,1)
7731                 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7732                   IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7733                     PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7734      &              PMAS(PYCOMP(KFDP(IDC,2)),1)
7735                     IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7736      &              PMAS(PYCOMP(KFDP(IDC,3)),1)
7737                     PMMN(I)=MIN(PMMN(I),PMSUM)
7738                   ENDIF
7739   100           CONTINUE
7740               ELSEIF(KFLW.EQ.6) THEN
7741                 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7742               ENDIF
7743             ENDIF
7744   110     CONTINUE
7745           IF(NBW.GE.1) THEN
7746             CKIN41=CKIN(41)
7747             CKIN43=CKIN(43)
7748             CKIN(41)=MAX(PMMN(1),CKIN(41))
7749             CKIN(43)=MAX(PMMN(2),CKIN(43))
7750             CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7751             CKIN(41)=CKIN41
7752             CKIN(43)=CKIN43
7753             IF(MINT(51).EQ.1) THEN
7754               WRITE(MSTU(11),5100) ISUB
7755               MSUB(ISUB)=0
7756               GOTO 460
7757             ENDIF
7758             SQM3=PQM3**2
7759             SQM4=PQM4**2
7760           ENDIF
7761           IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7762           IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7763           IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7764             VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7765           ELSEIF(ISUB.EQ.96) THEN
7766             VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7767           ENDIF
7768         ENDIF
7769         VINT(63)=SQM3
7770         VINT(64)=SQM4
7771  
7772 C...Prepare for additional variable choices in 2 -> 3.
7773         IF(ISTSB.EQ.5) THEN
7774           VINT(201)=0D0
7775           IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7776           VINT(206)=VINT(201)
7777           IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7778           VINT(204)=PMAS(23,1)
7779           IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7780           IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7781           IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7782      &    .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7783      &         VINT(204)=VINT(201)
7784           VINT(209)=VINT(204)
7785           IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7786         ENDIF
7787  
7788 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7789         IPEAK7=0
7790         NPTS(1)=2+2*MINT(72)
7791         IF(MINT(47).EQ.1) THEN
7792           IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7793         ELSEIF(MINT(47).GE.5) THEN
7794           IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7795             NPTS(1)=NPTS(1)+1
7796             IPEAK7=1
7797           ENDIF
7798         ENDIF
7799         NPTS(2)=1
7800         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7801           IF(MINT(47).GE.2) NPTS(2)=2
7802           IF(MINT(47).GE.5) NPTS(2)=3
7803         ENDIF
7804         NPTS(3)=1
7805         IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7806           NPTS(3)=3
7807           IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7808           IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7809         ENDIF
7810         NPTS(4)=1
7811         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7812         NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7813  
7814 C...Reset coefficients of cross-section weighting.
7815         DO 120 J=1,20
7816           COEF(ISUB,J)=0D0
7817   120   CONTINUE
7818         IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7819      &   .AND.ISUB.LE.380)) THEN
7820           DO 125 J=1,2
7821             COEFX(ISUB,J)=0D0
7822  125      CONTINUE
7823         ENDIF
7824         COEF(ISUB,1)=1D0
7825         COEF(ISUB,8)=0.5D0
7826         COEF(ISUB,9)=0.5D0
7827         COEF(ISUB,13)=1D0
7828         COEF(ISUB,18)=1D0
7829         MCTH=0
7830         MTAUP=0
7831         METAUP=0
7832         VINT(23)=0D0
7833         VINT(26)=0D0
7834         SIGSAM=0D0
7835  
7836 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7837 C...in grid of phase space points.
7838         CALL PYKLIM(1)
7839         METAU=MINT(51)
7840         NACC=0
7841         DO 150 ITRY=1,NTRY
7842           MINT(51)=0
7843           IF(METAU.EQ.1) GOTO 150
7844           IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7845             MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7846             IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7847               MTAU=7
7848             ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7849               MTAU=MTAU+1              
7850             ENDIF
7851             RTAU=0.5D0
7852 C...Special case when both resonances have same mass,
7853 C...as is often the case in process 194.
7854 c           IF(MINT(72).GE.2) THEN
7855 c             IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7856 c    &        0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7857 c               IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7858 c                 RTAU=0.4D0
7859 c               ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7860 c                 RTAU=0.6D0
7861 c               ENDIF
7862 c             ENDIF
7863 c           ENDIF
7864             CALL PYKMAP(1,MTAU,RTAU)
7865             IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7866             METAUP=MINT(51)
7867           ENDIF
7868           IF(METAUP.EQ.1) GOTO 150
7869           IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7870      &    .EQ.0) THEN
7871             MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7872             CALL PYKMAP(4,MTAUP,0.5D0)
7873           ENDIF
7874           IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7875             CALL PYKLIM(2)
7876             MEYST=MINT(51)
7877           ENDIF
7878           IF(MEYST.EQ.1) GOTO 150
7879           IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7880             MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7881             IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7882             CALL PYKMAP(2,MYST,0.5D0)
7883             CALL PYKLIM(3)
7884             MECTH=MINT(51)
7885           ENDIF
7886           IF(MECTH.EQ.1) GOTO 150
7887           IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7888             MCTH=1+MOD(ITRY-1,NPTS(4))
7889             CALL PYKMAP(3,MCTH,0.5D0)
7890           ENDIF
7891           IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7892  
7893 C...Store position and limits.
7894           MINT(51)=0
7895           CALL PYKLIM(0)
7896           IF(MINT(51).EQ.1) GOTO 150
7897           NACC=NACC+1
7898           MVARPT(NACC,1)=MTAU
7899           MVARPT(NACC,2)=MTAUP
7900           MVARPT(NACC,3)=MYST
7901           MVARPT(NACC,4)=MCTH
7902           DO 130 J=1,30
7903             VINTPT(NACC,J)=VINT(10+J)
7904   130     CONTINUE
7905  
7906 C...Normal case: calculate cross-section.
7907           IF(ISTSB.NE.5) THEN
7908             CALL PYSIGH(NCHN,SIGS)
7909             IF(MWTXS.EQ.1) THEN
7910               CALL PYEVWT(WTXS)
7911               SIGS=WTXS*SIGS
7912             ENDIF
7913  
7914 C..2 -> 3: find highest value out of a number of tries.
7915           ELSE
7916             SIGS=0D0
7917             DO 140 IKIN3=1,MSTP(129)
7918               CALL PYKMAP(5,0,0D0)
7919               IF(MINT(51).EQ.1) GOTO 140
7920               CALL PYSIGH(NCHN,SIGTMP)
7921               IF(MWTXS.EQ.1) THEN
7922                 CALL PYEVWT(WTXS)
7923                 SIGTMP=WTXS*SIGTMP
7924               ENDIF
7925               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7926   140       CONTINUE
7927           ENDIF
7928  
7929 C...Store cross-section.
7930           SIGSPT(NACC)=SIGS
7931           IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7932           IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7933      &    VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7934   150   CONTINUE
7935         IF(NACC.EQ.0) THEN
7936           WRITE(MSTU(11),5100) ISUB
7937           MSUB(ISUB)=0
7938           GOTO 460
7939         ELSEIF(SIGSAM.EQ.0D0) THEN
7940           WRITE(MSTU(11),5300) ISUB
7941           MSUB(ISUB)=0
7942           GOTO 460
7943         ENDIF
7944         IF(ISUB.NE.96) NPOSI=NPOSI+1
7945  
7946 C...Calculate integrals in tau over maximal phase space limits.
7947         TAUMIN=VINT(11)
7948         TAUMAX=VINT(31)
7949         ATAU1=LOG(TAUMAX/TAUMIN)
7950         IF(NPTS(1).GE.2) THEN
7951           ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7952         ENDIF
7953         IF(NPTS(1).GE.4) THEN
7954           ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7955           ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7956      &    GAMR1
7957         ENDIF
7958         IF(NPTS(1).GE.6) THEN
7959           ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7960           ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7961      &    GAMR2
7962         ENDIF
7963         IF(NPTS(1).GE.8) THEN
7964           ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7965           ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7966      &    GAMR3
7967         ENDIF
7968         IF(IPEAK7.EQ.1) THEN
7969           ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7970         ENDIF
7971  
7972 C...Reset. Sum up cross-sections in points calculated.
7973         DO 320 IVAR=1,4
7974           IF(NPTS(IVAR).EQ.1) GOTO 320
7975           IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7976           NBIN=NPTS(IVAR)
7977           DO 170 J1=1,NBIN
7978             NAREL(J1)=0
7979             WTREL(J1)=0D0
7980             COEFU(J1)=0D0
7981             DO 160 J2=1,NBIN
7982               WTMAT(J1,J2)=0D0
7983   160       CONTINUE
7984   170     CONTINUE
7985           DO 180 IACC=1,NACC
7986             IBIN=MVARPT(IACC,IVAR)
7987             IF(IVAR.EQ.1) THEN
7988               IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7989                 IBIN=IBIN-1
7990               ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7991                 IBIN=3+2*MINT(72)
7992               ENDIF
7993             ENDIF
7994             IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7995             NAREL(IBIN)=NAREL(IBIN)+1
7996             WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7997  
7998 C...Sum up tau cross-section pieces in points used.
7999             IF(IVAR.EQ.1) THEN
8000               TAU=VINTPT(IACC,11)
8001               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8002               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
8003               IF(NBIN.GE.4) THEN
8004                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
8005                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
8006      &          ((TAU-TAUR1)**2+GAMR1**2)
8007               ENDIF
8008               IF(NBIN.GE.6) THEN
8009                 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
8010                 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
8011      &          ((TAU-TAUR2)**2+GAMR2**2)
8012               ENDIF
8013               IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
8014                 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
8015      &           +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8016               ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
8017                 WTMAT(IBIN,7)=WTMAT(IBIN,7)
8018      &           +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8019               ENDIF
8020               IF(MINT(72).EQ.3) THEN
8021                 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
8022      &           +(ATAU1/ATAU8)/(TAU+TAUR3)
8023                 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
8024      &           +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
8025               ENDIF
8026 C...Sum up tau' cross-section pieces in points used.
8027             ELSEIF(IVAR.EQ.2) THEN
8028               TAU=VINTPT(IACC,11)
8029               TAUP=VINTPT(IACC,16)
8030               TAUPMN=VINTPT(IACC,6)
8031               TAUPMX=VINTPT(IACC,26)
8032               ATAUP1=LOG(TAUPMX/TAUPMN)
8033               ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
8034               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8035               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
8036      &        (1D0-TAU/TAUP)**3/TAUP
8037               IF(NBIN.GE.3) THEN
8038                 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
8039                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
8040      &          TAUP/MAX(2D-10,1D0-TAUP)
8041               ENDIF
8042  
8043 C...Sum up y* cross-section pieces in points used.
8044             ELSEIF(IVAR.EQ.3) THEN
8045               YST=VINTPT(IACC,12)
8046               YSTMIN=VINTPT(IACC,2)
8047               YSTMAX=VINTPT(IACC,22)
8048               AYST0=YSTMAX-YSTMIN
8049               AYST1=0.5D0*(YSTMAX-YSTMIN)**2
8050               AYST2=AYST1
8051               AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
8052               WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
8053               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
8054               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
8055               IF(MINT(45).EQ.3) THEN
8056                 TAUE=VINTPT(IACC,11)
8057                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8058                 YST0=-0.5D0*LOG(TAUE)
8059                 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
8060      &          MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
8061                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
8062      &          MAX(1D-10,1D0-EXP(YST-YST0))
8063               ENDIF
8064               IF(MINT(46).EQ.3) THEN
8065                 TAUE=VINTPT(IACC,11)
8066                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8067                 YST0=-0.5D0*LOG(TAUE)
8068                 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
8069      &          MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
8070                 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
8071      &          MAX(1D-10,1D0-EXP(-YST-YST0))
8072               ENDIF
8073  
8074 C...Sum up cos(theta-hat) cross-section pieces in points used.
8075             ELSE
8076               RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
8077               RSQM=1D0+RM34
8078               CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
8079               CTHMIN=-CTHMAX
8080               IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
8081      &        (TAUMAX*VINT(2)))
8082               ACTH1=CTHMAX-CTHMIN
8083               ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
8084               ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
8085               ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
8086               ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
8087               CTH=VINTPT(IACC,13)
8088               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8089               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
8090      &        MAX(RM34,RSQM-CTH)
8091               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
8092      &        MAX(RM34,RSQM+CTH)
8093               WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
8094      &        MAX(RM34,RSQM-CTH)**2
8095               WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
8096      &        MAX(RM34,RSQM+CTH)**2
8097             ENDIF
8098   180     CONTINUE
8099  
8100 C...Check that equation system solvable.
8101           IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
8102           MSOLV=1
8103           WTRELS=0D0
8104           DO 190 IBIN=1,NBIN
8105             IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8106      &      IRED=1,NBIN),WTREL(IBIN)
8107             IF(NAREL(IBIN).EQ.0) MSOLV=0
8108             WTRELS=WTRELS+WTREL(IBIN)
8109   190     CONTINUE
8110           IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8111  
8112 C...Solve to find relative importance of cross-section pieces.
8113           IF(MSOLV.EQ.1) THEN
8114             DO 200 IBIN=1,NBIN
8115               WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8116               WTRSAV(IBIN)=WTREL(IBIN)
8117   200       CONTINUE
8118 C...Auxiliary vectors to record order of permutations
8119             DO I=1,NBIN
8120               IP(I) = I
8121               IQ(I) = I
8122             ENDDO
8123             DO 230 IRED=1,NBIN-1
8124               MROW=IRED
8125               RESMAX=ABS(WTREL(MROW))
8126 C...Find row with largest residual
8127               DO JBIN=IRED+1,NBIN
8128                 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8129                   MROW=JBIN
8130                   RESMAX=ABS(WTREL(MROW))
8131                 ENDIF
8132               ENDDO
8133               IF(RESMAX.LT.1D-20) THEN
8134                 MSOLV=0
8135                 GOTO 260
8136               ENDIF
8137               MCOL = IRED
8138               AMAX = ABS(WTMAT(MROW,MCOL))
8139 C...Find column with largest entry
8140               DO JBIN=IRED+1,NBIN
8141                 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8142                   MCOL = JBIN
8143                   AMAX = ABS(WTMAT(MROW,MCOL))
8144                 ENDIF
8145               ENDDO
8146 C...Swap rows if necessary
8147               IF(MROW.NE.IRED) THEN
8148                 DO JBIN=1,NBIN
8149                   TMPE=WTMAT(IRED,JBIN)
8150                   WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8151                   WTMAT(MROW,JBIN)=TMPE
8152                 ENDDO
8153                 TMPE=WTREL(IRED)
8154                 WTREL(IRED)=WTREL(MROW)
8155                 WTREL(MROW)=TMPE
8156                 MTMP=IQ(IRED)
8157                 IQ(IRED)=IQ(MROW)
8158                 IQ(MROW)=MTMP
8159               ENDIF
8160 C...Swap columns if necessary
8161               IF(MCOL.NE.IRED) THEN
8162                 DO JBIN=1,NBIN
8163                   TMPE=WTMAT(JBIN,IRED)
8164                   WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8165                   WTMAT(JBIN,MCOL)=TMPE
8166                 ENDDO
8167                 MTMP=IP(IRED)
8168                 IP(IRED)=IP(MCOL)
8169                 IP(MCOL)=MTMP
8170               ENDIF
8171 C...Begin eliminating equations
8172               DO 220 IBIN=IRED+1,NBIN
8173                 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8174                   MSOLV=0
8175                   GOTO 260
8176                 ENDIF
8177 C                RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8178                 RQTU=WTMAT(IBIN,IRED)
8179                 RQTL=WTMAT(IRED,IRED)
8180 C...Switch order of operations
8181                 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8182      $            (WTREL(IRED)/RQTL)
8183                 DO 210 ICOE=IRED,NBIN
8184                    WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8185      $                RQTU*(WTMAT(IRED,ICOE)/RQTL)
8186   210           CONTINUE
8187   220         CONTINUE
8188   230       CONTINUE
8189             DO 250 IRED=NBIN,1,-1
8190               DO 240 ICOE=IRED+1,NBIN
8191                 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8192   240         CONTINUE
8193               IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8194                 MSOLV=0
8195                 GOTO 260
8196               ENDIF
8197               COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8198               TEMPC(IRED)=COEFU(IRED)
8199   250       CONTINUE
8200 C...Return to original order
8201             DO IBIN=1,NBIN
8202               MTMP=IP(IBIN)
8203               COEFU(MTMP)=TEMPC(IBIN)
8204             ENDDO
8205           ENDIF
8206  
8207 C...Share evenly if failure.
8208   260     IF(MSOLV.EQ.0) THEN
8209             DO 270 IBIN=1,NBIN
8210               COEFU(IBIN)=1D0
8211               WTRELN(IBIN)=0.1D0
8212               IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8213      &        WTRSAV(IBIN)/WTRELS)
8214   270       CONTINUE
8215           ENDIF
8216  
8217 C...Normalize coefficients, with piece shared democratically.
8218           COEFSU=0D0
8219           WTRELS=0D0
8220           DO 280 IBIN=1,NBIN
8221             COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8222             COEFSU=COEFSU+COEFU(IBIN)
8223             WTRELS=WTRELS+WTRELN(IBIN)
8224   280     CONTINUE
8225           IF(COEFSU.GT.0D0) THEN
8226             DO 290 IBIN=1,NBIN
8227               COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8228      &        (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8229   290       CONTINUE
8230           ELSE
8231             DO 300 IBIN=1,NBIN
8232               COEFO(IBIN)=1D0/NBIN
8233   300       CONTINUE
8234           ENDIF
8235           IF(IVAR.EQ.1) IOFF=0
8236           IF(IVAR.EQ.2) IOFF=17
8237           IF(IVAR.EQ.3) IOFF=7
8238           IF(IVAR.EQ.4) IOFF=12
8239           DO 310 IBIN=1,NBIN
8240             ICOF=IOFF+IBIN
8241             IF(IVAR.EQ.1) THEN
8242               IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8243                 ICOF=7
8244               ENDIF
8245             ENDIF
8246             IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8247             IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8248               COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8249             ELSE
8250               COEF(ISUB,ICOF)=COEFO(IBIN)
8251             ENDIF
8252   310     CONTINUE
8253           
8254           IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8255      &       (COEFO(IBIN),IBIN=1,NBIN)
8256 
8257   320   CONTINUE
8258  
8259 C...Find two most promising maxima among points previously determined.
8260         DO 330 J=1,4
8261           IACCMX(J)=0
8262           SIGSMX(J)=0D0
8263   330   CONTINUE
8264         NMAX=0
8265         DO 390 IACC=1,NACC
8266           DO 340 J=1,30
8267             VINT(10+J)=VINTPT(IACC,J)
8268   340     CONTINUE
8269           IF(ISTSB.NE.5) THEN
8270             CALL PYSIGH(NCHN,SIGS)
8271             IF(MWTXS.EQ.1) THEN
8272               CALL PYEVWT(WTXS)
8273               SIGS=WTXS*SIGS
8274             ENDIF
8275           ELSE
8276             SIGS=0D0
8277             DO 350 IKIN3=1,MSTP(129)
8278               CALL PYKMAP(5,0,0D0)
8279               IF(MINT(51).EQ.1) GOTO 350
8280               CALL PYSIGH(NCHN,SIGTMP)
8281               IF(MWTXS.EQ.1) THEN
8282                 CALL PYEVWT(WTXS)
8283                 SIGTMP=WTXS*SIGTMP
8284               ENDIF
8285               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8286   350       CONTINUE
8287           ENDIF
8288           IEQ=0
8289           DO 360 IMV=1,NMAX
8290             IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8291   360     CONTINUE
8292           IF(IEQ.EQ.0) THEN
8293             DO 370 IMV=NMAX,1,-1
8294               IIN=IMV+1
8295               IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8296               IACCMX(IMV+1)=IACCMX(IMV)
8297               SIGSMX(IMV+1)=SIGSMX(IMV)
8298   370       CONTINUE
8299             IIN=1
8300   380       IACCMX(IIN)=IACC
8301             SIGSMX(IIN)=SIGS
8302             IF(NMAX.LE.1) NMAX=NMAX+1
8303           ENDIF
8304   390   CONTINUE
8305  
8306 C...Read out starting position for search.
8307         IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8308         SIGSAM=SIGSMX(1)
8309         DO 440 IMAX=1,NMAX
8310           IACC=IACCMX(IMAX)
8311           MTAU=MVARPT(IACC,1)
8312           MTAUP=MVARPT(IACC,2)
8313           MYST=MVARPT(IACC,3)
8314           MCTH=MVARPT(IACC,4)
8315           VTAU=0.5D0
8316           VYST=0.5D0
8317           VCTH=0.5D0
8318           VTAUP=0.5D0
8319  
8320 C...Starting point and step size in parameter space.
8321           DO 430 IRPT=1,2
8322             DO 420 IVAR=1,4
8323               IF(NPTS(IVAR).EQ.1) GOTO 420
8324               IF(IVAR.EQ.1) VVAR=VTAU
8325               IF(IVAR.EQ.2) VVAR=VTAUP
8326               IF(IVAR.EQ.3) VVAR=VYST
8327               IF(IVAR.EQ.4) VVAR=VCTH
8328               IF(IVAR.EQ.1) MVAR=MTAU
8329               IF(IVAR.EQ.2) MVAR=MTAUP
8330               IF(IVAR.EQ.3) MVAR=MYST
8331               IF(IVAR.EQ.4) MVAR=MCTH
8332               IF(IRPT.EQ.1) VDEL=0.1D0
8333               IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8334      &        0.98D0-VVAR))
8335               IF(IRPT.EQ.1) VMAR=0.02D0
8336               IF(IRPT.EQ.2) VMAR=0.002D0
8337               IMOV0=1
8338               IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8339               DO 410 IMOV=IMOV0,8
8340  
8341 C...Define new point in parameter space.
8342                 IF(IMOV.EQ.0) THEN
8343                   INEW=2
8344                   VNEW=VVAR
8345                 ELSEIF(IMOV.EQ.1) THEN
8346                   INEW=3
8347                   VNEW=VVAR+VDEL
8348                 ELSEIF(IMOV.EQ.2) THEN
8349                   INEW=1
8350                   VNEW=VVAR-VDEL
8351                 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8352      &            VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8353                   VVAR=VVAR+VDEL
8354                   SIGSSM(1)=SIGSSM(2)
8355                   SIGSSM(2)=SIGSSM(3)
8356                   INEW=3
8357                   VNEW=VVAR+VDEL
8358                 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8359      &            VVAR-2D0*VDEL.GT.VMAR) THEN
8360                   VVAR=VVAR-VDEL
8361                   SIGSSM(3)=SIGSSM(2)
8362                   SIGSSM(2)=SIGSSM(1)
8363                   INEW=1
8364                   VNEW=VVAR-VDEL
8365                 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8366                   VDEL=0.5D0*VDEL
8367                   VVAR=VVAR+VDEL
8368                   SIGSSM(1)=SIGSSM(2)
8369                   INEW=2
8370                   VNEW=VVAR
8371                 ELSE
8372                   VDEL=0.5D0*VDEL
8373                   VVAR=VVAR-VDEL
8374                   SIGSSM(3)=SIGSSM(2)
8375                   INEW=2
8376                   VNEW=VVAR
8377                 ENDIF
8378  
8379 C...Convert to relevant variables and find derived new limits.
8380                 ILERR=0
8381                 IF(IVAR.EQ.1) THEN
8382                   VTAU=VNEW
8383                   CALL PYKMAP(1,MTAU,VTAU)
8384                   IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8385                     CALL PYKLIM(4)
8386                     IF(MINT(51).EQ.1) ILERR=1
8387                   ENDIF
8388                 ENDIF
8389                 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8390      &          ILERR.EQ.0) THEN
8391                   IF(IVAR.EQ.2) VTAUP=VNEW
8392                   CALL PYKMAP(4,MTAUP,VTAUP)
8393                 ENDIF
8394                 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8395                   CALL PYKLIM(2)
8396                   IF(MINT(51).EQ.1) ILERR=1
8397                 ENDIF
8398                 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8399                   IF(IVAR.EQ.3) VYST=VNEW
8400                   CALL PYKMAP(2,MYST,VYST)
8401                   CALL PYKLIM(3)
8402                   IF(MINT(51).EQ.1) ILERR=1
8403                 ENDIF
8404                 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8405      &          ILERR.EQ.0) THEN
8406                   IF(IVAR.EQ.4) VCTH=VNEW
8407                   CALL PYKMAP(3,MCTH,VCTH)
8408                 ENDIF
8409                 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8410  
8411 C...Evaluate cross-section. Save new maximum. Final maximum.
8412                 IF(ILERR.NE.0) THEN
8413                    SIGS=0.
8414                 ELSEIF(ISTSB.NE.5) THEN
8415                   CALL PYSIGH(NCHN,SIGS)
8416                   IF(MWTXS.EQ.1) THEN
8417                     CALL PYEVWT(WTXS)
8418                     SIGS=WTXS*SIGS
8419                   ENDIF
8420                 ELSE
8421                   SIGS=0D0
8422                   DO 400 IKIN3=1,MSTP(129)
8423                     CALL PYKMAP(5,0,0D0)
8424                     IF(MINT(51).EQ.1) GOTO 400
8425                     CALL PYSIGH(NCHN,SIGTMP)
8426                     IF(MWTXS.EQ.1) THEN
8427                         CALL PYEVWT(WTXS)
8428                         SIGTMP=WTXS*SIGTMP
8429                     ENDIF
8430                     IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8431   400             CONTINUE
8432                 ENDIF
8433                 SIGSSM(INEW)=SIGS
8434                 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8435                 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8436      &          IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8437   410         CONTINUE
8438   420       CONTINUE
8439   430     CONTINUE
8440   440   CONTINUE
8441         IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8442         XSEC(ISUB,1)=1.05D0*SIGSAM
8443 C...Add extra headroom for UED
8444         IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8445         IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8446      &  WTGAGA*XSEC(ISUB,1)
8447   450   CONTINUE
8448         IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8449      &  PARP(174)*XSEC(ISUB,1)
8450         IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8451   460 CONTINUE
8452       MINT(51)=0
8453  
8454 C...Print summary table.
8455       IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8456         IF(MSTP(127).NE.1) THEN
8457           WRITE(MSTU(11),5900)
8458           CALL PYSTOP(1)
8459         ELSE
8460           WRITE(MSTU(11),6400)
8461           MSTI(53)=1
8462         ENDIF
8463       ENDIF
8464       IF(MSTP(122).GE.1) THEN
8465         WRITE(MSTU(11),6000)
8466         WRITE(MSTU(11),6100)
8467         DO 470 ISUB=1,500
8468           IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8469           IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8470           IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8471      &    GOTO 470
8472           IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8473           IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8474      &    .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8475           IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8476           WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8477   470   CONTINUE
8478         WRITE(MSTU(11),6300)
8479       ENDIF
8480  
8481 C...Format statements for maximization results.
8482  5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8483      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,
8484      &'cth',9X,'tau''',7X,'sigma')
8485  5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8486      &'phase space.'/1X,'Process switched off!')
8487  5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8488  5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8489      &'cross-section.'/1X,'Process switched off!')
8490  5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8491  5500 FORMAT(1X,1P,10D11.3)
8492  5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8493  5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8494      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8495  5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8496  5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8497      &'cross-section.'/1X,'Execution stopped!')
8498  6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8499      &'cross-section maximum search',1X,8('*'))
8500  6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',
8501      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',
8502      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8503  6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8504  6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8505  6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8506      &'cross-section.'/
8507      &1X,'Execution will stop if you try to generate events.')
8508  
8509       RETURN
8510       END
8511  
8512 C*********************************************************************
8513  
8514 C...PYPILE
8515 C...Initializes multiplicity distribution and selects mutliplicity
8516 C...of pileup events, i.e. several events occuring at the same
8517 C...beam crossing.
8518  
8519       SUBROUTINE PYPILE(MPILE)
8520  
8521 C...Double precision and integer declarations.
8522       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8523       IMPLICIT INTEGER(I-N)
8524       INTEGER PYK,PYCHGE,PYCOMP
8525 C...Commonblocks.
8526       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8527       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8528       COMMON/PYINT1/MINT(400),VINT(400)
8529       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8530       SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8531 C...Local arrays and saved variables.
8532       DIMENSION WTI(0:200)
8533       SAVE IMIN,IMAX,WTI,WTS
8534  
8535 C...Sum of allowed cross-sections for pileup events.
8536       IF(MPILE.EQ.1) THEN
8537         VINT(131)=SIGT(0,0,5)
8538         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8539         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8540         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8541         IF(MSTP(133).LE.0) RETURN
8542  
8543 C...Initialize multiplicity distribution at maximum.
8544         XNAVE=VINT(131)*PARP(131)
8545         IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8546         INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8547         WTI(INAVE)=1D0
8548         WTS=WTI(INAVE)
8549         WTN=WTI(INAVE)*INAVE
8550  
8551 C...Find shape of multiplicity distribution below maximum.
8552         IMIN=INAVE
8553         DO 100 I=INAVE-1,1,-1
8554           IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8555           IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8556           IF(WTI(I).LT.1D-6) GOTO 110
8557           WTS=WTS+WTI(I)
8558           WTN=WTN+WTI(I)*I
8559           IMIN=I
8560   100   CONTINUE
8561  
8562 C...Find shape of multiplicity distribution above maximum.
8563   110   IMAX=INAVE
8564         DO 120 I=INAVE+1,200
8565           IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8566           IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8567           IF(WTI(I).LT.1D-6) GOTO 130
8568           WTS=WTS+WTI(I)
8569           WTN=WTN+WTI(I)*I
8570           IMAX=I
8571   120   CONTINUE
8572   130   VINT(132)=XNAVE
8573         VINT(133)=WTN/WTS
8574         IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8575      &  WTS/(WTS+WTI(1)/XNAVE)
8576         IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8577         IF(MSTP(133).GE.2) VINT(134)=XNAVE
8578  
8579 C...Pick multiplicity of pileup events.
8580       ELSE
8581         IF(MSTP(133).LE.0) THEN
8582           MINT(81)=MAX(1,MSTP(134))
8583         ELSE
8584           WTR=WTS*PYR(0)
8585           DO 140 I=IMIN,IMAX
8586             MINT(81)=I
8587             WTR=WTR-WTI(I)
8588             IF(WTR.LE.0D0) GOTO 150
8589   140     CONTINUE
8590   150     CONTINUE
8591         ENDIF
8592       ENDIF
8593  
8594 C...Format statement for error message.
8595  5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8596      &'crossing too large, ',1P,D12.4)
8597  
8598       RETURN
8599       END
8600  
8601 C*********************************************************************
8602  
8603 C...PYSAVE
8604 C...Saves and restores parameter and cross section values for the
8605 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8606 C...Also makes random choice between alternatives.
8607  
8608       SUBROUTINE PYSAVE(ISAVE,IGA)
8609  
8610 C...Double precision and integer declarations.
8611       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8612       IMPLICIT INTEGER(I-N)
8613       INTEGER PYK,PYCHGE,PYCOMP
8614 C...Commonblocks.
8615       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8616       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8617       COMMON/PYINT1/MINT(400),VINT(400)
8618       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8619       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8620       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8621       SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8622 C...Local arrays and saved variables.
8623       DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8624      &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8625      &INTCP(15,20),RECP(15,20)
8626       SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8627  
8628 C...Save list of subprocesses and cross-section information.
8629       IF(ISAVE.EQ.1) THEN
8630         ICP=0
8631         DO 120 I=1,500
8632           IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8633           ICP=ICP+1
8634           NSUBCP(IGA,ICP)=I
8635           MSUBCP(IGA,ICP)=MSUB(I)
8636           DO 100 J=1,20
8637             COEFCP(IGA,ICP,J)=COEF(I,J)
8638   100     CONTINUE
8639           DO 110 J=1,3
8640             NGENCP(IGA,ICP,J)=NGEN(I,J)
8641             XSECCP(IGA,ICP,J)=XSEC(I,J)
8642   110     CONTINUE
8643   120   CONTINUE
8644         NCP(IGA)=ICP
8645         DO 130 J=1,3
8646           NGENCP(IGA,0,J)=NGEN(0,J)
8647           XSECCP(IGA,0,J)=XSEC(0,J)
8648   130   CONTINUE
8649         DO 160 I1=0,6
8650           DO 150 I2=0,6
8651             DO 140 J=0,5
8652               SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8653   140       CONTINUE
8654   150     CONTINUE
8655   160   CONTINUE
8656  
8657 C...Save various common process variables.
8658         DO 170 J=1,10
8659           INTCP(IGA,J)=MINT(40+J)
8660   170   CONTINUE
8661         INTCP(IGA,11)=MINT(101)
8662         INTCP(IGA,12)=MINT(102)
8663         INTCP(IGA,13)=MINT(107)
8664         INTCP(IGA,14)=MINT(108)
8665         INTCP(IGA,15)=MINT(123)
8666         RECP(IGA,1)=CKIN(3)
8667         RECP(IGA,2)=VINT(318)
8668  
8669 C...Save cross-section information only.
8670       ELSEIF(ISAVE.EQ.2) THEN
8671         DO 190 ICP=1,NCP(IGA)
8672           I=NSUBCP(IGA,ICP)
8673           DO 180 J=1,3
8674             NGENCP(IGA,ICP,J)=NGEN(I,J)
8675             XSECCP(IGA,ICP,J)=XSEC(I,J)
8676   180     CONTINUE
8677   190   CONTINUE
8678         DO 200 J=1,3
8679           NGENCP(IGA,0,J)=NGEN(0,J)
8680           XSECCP(IGA,0,J)=XSEC(0,J)
8681   200   CONTINUE
8682  
8683 C...Choose between allowed alternatives.
8684       ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8685         IF(ISAVE.EQ.4) THEN
8686           XSUMCP=0D0
8687           DO 210 IG=1,MINT(121)
8688             XSUMCP=XSUMCP+XSECCP(IG,0,1)
8689   210     CONTINUE
8690           XSUMCP=XSUMCP*PYR(0)
8691           DO 220 IG=1,MINT(121)
8692             IGA=IG
8693             XSUMCP=XSUMCP-XSECCP(IG,0,1)
8694             IF(XSUMCP.LE.0D0) GOTO 230
8695   220     CONTINUE
8696   230     CONTINUE
8697         ENDIF
8698  
8699 C...Restore cross-section information.
8700         DO 240 I=1,500
8701           MSUB(I)=0
8702   240   CONTINUE
8703         DO 270 ICP=1,NCP(IGA)
8704           I=NSUBCP(IGA,ICP)
8705           MSUB(I)=MSUBCP(IGA,ICP)
8706           DO 250 J=1,20
8707             COEF(I,J)=COEFCP(IGA,ICP,J)
8708   250     CONTINUE
8709           DO 260 J=1,3
8710             NGEN(I,J)=NGENCP(IGA,ICP,J)
8711             XSEC(I,J)=XSECCP(IGA,ICP,J)
8712   260     CONTINUE
8713   270   CONTINUE
8714         DO 280 J=1,3
8715           NGEN(0,J)=NGENCP(IGA,0,J)
8716           XSEC(0,J)=XSECCP(IGA,0,J)
8717   280   CONTINUE
8718         DO 310 I1=0,6
8719           DO 300 I2=0,6
8720             DO 290 J=0,5
8721               SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8722   290       CONTINUE
8723   300     CONTINUE
8724   310   CONTINUE
8725  
8726 C...Restore various common process variables.
8727         DO 320 J=1,10
8728           MINT(40+J)=INTCP(IGA,J)
8729   320   CONTINUE
8730         MINT(101)=INTCP(IGA,11)
8731         MINT(102)=INTCP(IGA,12)
8732         MINT(107)=INTCP(IGA,13)
8733         MINT(108)=INTCP(IGA,14)
8734         MINT(123)=INTCP(IGA,15)
8735         CKIN(3)=RECP(IGA,1)
8736         CKIN(1)=2D0*CKIN(3)
8737         VINT(318)=RECP(IGA,2)
8738  
8739 C...Sum up cross-section info (for PYSTAT).
8740       ELSEIF(ISAVE.EQ.5) THEN
8741         DO 330 I=1,500
8742           MSUB(I)=0
8743           NGEN(I,1)=0
8744           NGEN(I,3)=0
8745           XSEC(I,3)=0D0
8746   330   CONTINUE
8747         NGEN(0,1)=0
8748         NGEN(0,2)=0
8749         NGEN(0,3)=0
8750         XSEC(0,3)=0
8751         DO 350 IG=1,MINT(121)
8752           DO 340 ICP=1,NCP(IG)
8753             I=NSUBCP(IG,ICP)
8754             IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8755             NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8756             NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8757             XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8758   340     CONTINUE
8759           NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8760           NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8761           NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8762           XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8763   350   CONTINUE
8764       ENDIF
8765  
8766       RETURN
8767       END
8768  
8769 C*********************************************************************
8770  
8771 C...PYGAGA
8772 C...For lepton beams it gives photon-hadron or photon-photon systems
8773 C...to be treated with the ordinary machinery and combines this with a
8774 C...description of the lepton -> lepton + photon branching.
8775  
8776       SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8777  
8778 C...Double precision and integer declarations.
8779       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8780       IMPLICIT INTEGER(I-N)
8781       INTEGER PYK,PYCHGE,PYCOMP
8782 C...Commonblocks.
8783       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8784       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8785       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8786       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8787       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8788       COMMON/PYINT1/MINT(400),VINT(400)
8789       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8790       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8791      &/PYINT5/
8792 C...Local variables and data statement.
8793       DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8794      &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8795       SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8796       DATA EPS/1D-4/
8797  
8798 C...Initialize generation of photons inside leptons.
8799       IF(IGAGA.EQ.1) THEN
8800  
8801 C...Save quantities on incoming lepton system.
8802         VINT(301)=VINT(1)
8803         VINT(302)=VINT(2)
8804         PMS(1)=VINT(303)**2
8805         IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8806         PMS(2)=VINT(304)**2
8807         IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8808         PMC(3)=VINT(302)-PMS(1)-PMS(2)
8809         W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8810  
8811 C...Calculate range of x and Q2 values allowed in generation.
8812         DO 100 I=1,2
8813           PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8814           IF(MINT(140+I).NE.0) THEN
8815             XMIN(I)=MAX(CKIN(59+2*I),EPS)
8816             XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8817      &      PMC(I),1D0-EPS)
8818             YMIN=MAX(CKIN(71+2*I),EPS)
8819             YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8820             IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8821      &      (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8822             XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8823             THEMIN=MAX(CKIN(67+2*I),0D0)
8824             THEMAX=MIN(CKIN(68+2*I),PARU(1))
8825             IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8826             Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8827      &      ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8828      &      2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8829             Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8830      &      ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8831      &      2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8832             IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8833 C...W limits when lepton on one side only.
8834             IF(MINT(143-I).EQ.0) THEN
8835               XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8836               IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8837      &        (CKIN(78)**2-PMS(3-I))/PMC(I))
8838             ENDIF
8839           ENDIF
8840   100   CONTINUE
8841  
8842 C...W limits when lepton on both sides.
8843         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8844           IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8845      &    (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8846           IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8847      &    (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8848           IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8849             XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8850      &      PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8851             XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8852      &      PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8853           ELSE
8854             XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8855             XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8856           ENDIF
8857         ENDIF
8858  
8859 C...Q2 and W values and photon flux weight factors for initialization.
8860       ELSEIF(IGAGA.EQ.2) THEN
8861         ISUB=MINT(1)
8862         MINT(15)=0
8863         MINT(16)=0
8864  
8865 C...W value for photon on one or both sides, and for processes
8866 C...with gamma-gamma cross section peaked at small shat.
8867         IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8868           VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8869         ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8870           VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8871         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8872           VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8873           IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8874         ELSE
8875           VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8876           IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8877         ENDIF
8878         VINT(1)=SQRT(MAX(0D0,VINT(2)))
8879  
8880 C...Upper estimate of photon flux weight factor.
8881 C...Initialization Q2 scale. Flag incoming unresolved photon.
8882         WTGAGA=1D0
8883         DO 110 I=1,2
8884           IF(MINT(140+I).NE.0) THEN
8885             WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8886      &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8887             IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8888      &      THEN
8889               Q2INIT=5D0+Q2MIN(3-I)
8890             ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8891               Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8892             ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8893               Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8894             ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8895      &      (ISUB.EQ.139.AND.I.EQ.1)) THEN
8896               Q2INIT=VINT(2)/3D0
8897             ELSEIF(ISUB.EQ.140) THEN
8898               Q2INIT=VINT(2)/2D0
8899             ELSE
8900               Q2INIT=Q2MIN(I)
8901             ENDIF
8902             VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8903             IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8904      &      MINT(14+I)=22
8905             VINT(306+I)=VINT(2+I)**2
8906           ENDIF
8907   110   CONTINUE
8908         VINT(320)=WTGAGA
8909  
8910 C...Update pTmin and cross section information.
8911         IF(MSTP(82).LE.1) THEN
8912           PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8913         ELSE
8914           PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8915         ENDIF
8916         VINT(149)=4D0*PTMN**2/VINT(2)
8917         VINT(154)=PTMN
8918         CALL PYXTOT
8919         VINT(318)=VINT(317)
8920  
8921 C...Generate photons inside leptons and
8922 C...calculate photon flux weight factors.
8923       ELSEIF(IGAGA.EQ.3) THEN
8924         ISUB=MINT(1)
8925         MINT(15)=0
8926         MINT(16)=0
8927  
8928 C...Generate phase space point and check against cuts.
8929         LOOP=0
8930   120   LOOP=LOOP+1
8931         DO 130 I=1,2
8932           IF(MINT(140+I).NE.0) THEN
8933 C...Pick x and Q2
8934             X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8935             Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8936 C...Cuts on internal consistency in x and Q2.
8937             IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8938             IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8939      &      (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8940 C...Cuts on y and theta.
8941             Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8942             IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8943             RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8944      &      ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8945             THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8946             IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8947             IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8948      &      GOTO 120
8949  
8950 C...Phi angle isotropic. Reconstruct pT.
8951             PHI(I)=PARU(2)*PYR(0)
8952             PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8953      &      PMS(I))*SIN(THETA(I))
8954  
8955 C...Store info on variables selected, for documentation purposes.
8956             VINT(2+I)=-SQRT(Q2(I))
8957             VINT(304+I)=X(I)
8958             VINT(306+I)=Q2(I)
8959             VINT(308+I)=Y(I)
8960             VINT(310+I)=THETA(I)
8961             VINT(312+I)=PHI(I)
8962           ELSE
8963             VINT(304+I)=1D0
8964             VINT(306+I)=0D0
8965             VINT(308+I)=1D0
8966             VINT(310+I)=0D0
8967             VINT(312+I)=0D0
8968           ENDIF
8969   130   CONTINUE
8970  
8971 C...Cut on W combines info from two sides.
8972         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8973           W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8974      &    2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8975      &    SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8976      &    SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8977           IF(W2.LT.W2MIN) GOTO 120
8978           IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8979           PMS1=-Q2(1)
8980           PMS2=-Q2(2)
8981         ELSEIF(MINT(141).NE.0) THEN
8982           W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8983           PMS1=-Q2(1)
8984           PMS2=PMS(2)
8985         ELSEIF(MINT(142).NE.0) THEN
8986           W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8987           PMS1=PMS(1)
8988           PMS2=-Q2(2)
8989         ENDIF
8990  
8991 C...Store kinematics info for photon(s) in subsystem cm frame.
8992         VINT(2)=W2
8993         VINT(1)=SQRT(W2)
8994         VINT(291)=0D0
8995         VINT(292)=0D0
8996         VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8997         VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8998         VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8999         VINT(296)=0D0
9000         VINT(297)=0D0
9001         VINT(298)=-VINT(293)
9002         VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
9003         VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
9004  
9005 C...Assign weight for photon flux; different for transverse and
9006 C...longitudinal photons. Flag incoming unresolved photon.
9007         WTGAGA=1D0
9008         DO 140 I=1,2
9009           IF(MINT(140+I).NE.0) THEN
9010             WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
9011      &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
9012             IF(MSTP(16).EQ.0) THEN
9013               XY=X(I)
9014             ELSE
9015               WTGAGA=WTGAGA*X(I)/Y(I)
9016               XY=Y(I)
9017             ENDIF
9018             IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
9019               WTGAGA=WTGAGA*(1D0-XY)
9020             ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
9021               WTGAGA=WTGAGA*(1D0-XY)
9022             ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
9023               WTGAGA=WTGAGA*(1D0-XY)
9024             ELSE
9025               WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
9026      &        PMS(I)*XY**2/Q2(I))
9027             ENDIF
9028             IF(MINT(106+I).EQ.0) MINT(14+I)=22
9029           ENDIF
9030   140   CONTINUE
9031         VINT(319)=WTGAGA
9032         MINT(143)=LOOP
9033  
9034 C...Update pTmin and cross section information.
9035         IF(MSTP(82).LE.1) THEN
9036           PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
9037         ELSE
9038           PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
9039         ENDIF
9040         VINT(149)=4D0*PTMN**2/VINT(2)
9041         VINT(154)=PTMN
9042         CALL PYXTOT
9043  
9044 C...Reconstruct kinematics of photons inside leptons.
9045       ELSEIF(IGAGA.EQ.4) THEN
9046  
9047 C...Make place for incoming particles and scattered leptons.
9048         MOVE=3
9049         IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
9050         MINT(4)=MINT(4)+MOVE
9051         DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
9052           IF(K(I,1).EQ.21) THEN
9053             DO 150 J=1,5
9054               K(I+MOVE,J)=K(I,J)
9055               P(I+MOVE,J)=P(I,J)
9056               V(I+MOVE,J)=V(I,J)
9057   150       CONTINUE
9058             IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9059      &      K(I+MOVE,3)=K(I,3)+MOVE
9060             IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
9061      &      K(I+MOVE,4)=K(I,4)+MOVE
9062             IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
9063      &      K(I+MOVE,5)=K(I,5)+MOVE
9064           ENDIF
9065   160   CONTINUE
9066         DO 170 I=MINT(84)+1,N
9067           IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9068      &    K(I,3)=K(I,3)+MOVE
9069   170   CONTINUE
9070  
9071 C...Fill in incoming particles.
9072         DO 190 I=MINT(83)+1,MINT(83)+MOVE
9073           DO 180 J=1,5
9074             K(I,J)=0
9075             P(I,J)=0D0
9076             V(I,J)=0D0
9077   180     CONTINUE
9078   190   CONTINUE
9079         DO 200 I=1,2
9080           K(MINT(83)+I,1)=21
9081           IF(MINT(140+I).NE.0) THEN
9082             K(MINT(83)+I,2)=MINT(140+I)
9083             P(MINT(83)+I,5)=VINT(302+I)
9084           ELSE
9085             K(MINT(83)+I,2)=MINT(10+I)
9086             P(MINT(83)+I,5)=VINT(2+I)
9087           ENDIF
9088           P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
9089      &    VINT(302))*(-1D0)**(I+1)
9090           P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
9091   200   CONTINUE
9092  
9093 C...New mother-daughter relations in documentation section.
9094         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
9095           K(MINT(83)+1,4)=MINT(83)+3
9096           K(MINT(83)+1,5)=MINT(83)+5
9097           K(MINT(83)+2,4)=MINT(83)+4
9098           K(MINT(83)+2,5)=MINT(83)+6
9099           K(MINT(83)+3,3)=MINT(83)+1
9100           K(MINT(83)+5,3)=MINT(83)+1
9101           K(MINT(83)+4,3)=MINT(83)+2
9102           K(MINT(83)+6,3)=MINT(83)+2
9103         ELSEIF(MINT(141).NE.0) THEN
9104           K(MINT(83)+1,4)=MINT(83)+3
9105           K(MINT(83)+1,5)=MINT(83)+4
9106           K(MINT(83)+2,4)=MINT(83)+5
9107           K(MINT(83)+3,3)=MINT(83)+1
9108           K(MINT(83)+4,3)=MINT(83)+1
9109           K(MINT(83)+5,3)=MINT(83)+2
9110         ELSEIF(MINT(142).NE.0) THEN
9111           K(MINT(83)+1,4)=MINT(83)+4
9112           K(MINT(83)+2,4)=MINT(83)+3
9113           K(MINT(83)+2,5)=MINT(83)+5
9114           K(MINT(83)+3,3)=MINT(83)+2
9115           K(MINT(83)+4,3)=MINT(83)+1
9116           K(MINT(83)+5,3)=MINT(83)+2
9117         ENDIF
9118  
9119 C...Fill scattered lepton(s).
9120         DO 210 I=1,2
9121           IF(MINT(140+I).NE.0) THEN
9122             LSC=MINT(83)+MIN(I+2,MOVE)
9123             K(LSC,1)=21
9124             K(LSC,2)=MINT(140+I)
9125             P(LSC,1)=PT(I)*COS(PHI(I))
9126             P(LSC,2)=PT(I)*SIN(PHI(I))
9127             P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9128             P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9129      &      (-1D0)**(I-1)
9130             P(LSC,5)=VINT(302+I)
9131           ENDIF
9132   210   CONTINUE
9133  
9134 C...Find incoming four-vectors to subprocess.
9135         K(N+1,1)=21
9136         IF(MINT(141).NE.0) THEN
9137           DO 220 J=1,4
9138             P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9139   220     CONTINUE
9140         ELSE
9141           DO 230 J=1,4
9142             P(N+1,J)=P(MINT(83)+1,J)
9143   230     CONTINUE
9144         ENDIF
9145         K(N+2,1)=21
9146         IF(MINT(142).NE.0) THEN
9147           DO 240 J=1,4
9148             P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9149   240     CONTINUE
9150         ELSE
9151           DO 250 J=1,4
9152             P(N+2,J)=P(MINT(83)+2,J)
9153   250     CONTINUE
9154         ENDIF
9155  
9156 C...Define boost and rotation between hadronic subsystem and
9157 C...collision rest frame; boost hadronic subsystem to this frame.
9158         DO 260 J=1,3
9159           BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9160   260   CONTINUE
9161         CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9162         BPHI=PYANGL(P(N+1,1),P(N+1,2))
9163         CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9164         BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9165         CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9166      &  BETA(3))
9167  
9168 C...Add on scattered leptons to final state.
9169         DO 280 I=1,2
9170           IF(MINT(140+I).NE.0) THEN
9171             LSC=MINT(83)+MIN(I+2,MOVE)
9172             N=N+1
9173             DO 270 J=1,5
9174               K(N,J)=K(LSC,J)
9175               P(N,J)=P(LSC,J)
9176               V(N,J)=V(LSC,J)
9177   270       CONTINUE
9178             K(N,1)=1
9179             K(N,3)=LSC
9180           ENDIF
9181   280   CONTINUE
9182       ENDIF
9183  
9184       RETURN
9185       END
9186  
9187 C*********************************************************************
9188  
9189 C...PYRAND
9190 C...Generates quantities characterizing the high-pT scattering at the
9191 C...parton level according to the matrix elements. Chooses incoming,
9192 C...reacting partons, their momentum fractions and one of the possible
9193 C...subprocesses.
9194  
9195       SUBROUTINE PYRAND
9196  
9197 C...Double precision and integer declarations.
9198       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9199       IMPLICIT INTEGER(I-N)
9200       INTEGER PYK,PYCHGE,PYCOMP
9201 C...Parameter statement to help give large particle numbers.
9202       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9203      &KEXCIT=4000000,KDIMEN=5000000)
9204  
9205 C...User process initialization and event commonblocks.
9206       INTEGER MAXPUP
9207       PARAMETER (MAXPUP=100)
9208       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9209       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9210       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9211      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9212      &LPRUP(MAXPUP)
9213       INTEGER MAXNUP
9214       PARAMETER (MAXNUP=500)
9215       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9216       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9217       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9218      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9219      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9220       SAVE /HEPRUP/,/HEPEUP/
9221  
9222 C...Commonblocks.
9223       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9224       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9225       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9226       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9227       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9228       COMMON/PYINT1/MINT(400),VINT(400)
9229       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9230       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9231       COMMON/PYINT4/MWID(500),WIDS(500,5)
9232       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9233       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9234       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9235       COMMON/PYTCCO/COEFX(194:380,2)
9236       COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9237       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9238      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9239      &/TCPARA/
9240 C...Local arrays.
9241       DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9242  
9243 C...Parameters and data used in elastic/diffractive treatment.
9244       DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9245      &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9246  
9247 C...Initial values, specifically for (first) semihard interaction.
9248       MINT(10)=0
9249       MINT(17)=0
9250       MINT(18)=0
9251       VINT(143)=1D0
9252       VINT(144)=1D0
9253       VINT(157)=0D0
9254       VINT(158)=0D0
9255       MFAIL=0
9256       IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9257       ISUB=0
9258       ISTSB=0
9259       LOOP=0
9260   100 LOOP=LOOP+1
9261       MINT(51)=0
9262       MINT(143)=1
9263       VINT(97)=1D0
9264  
9265 C...Start by assuming incoming photon is entering subprocess.
9266       IF(MINT(11).EQ.22) THEN
9267          MINT(15)=22
9268          VINT(307)=VINT(3)**2
9269       ENDIF
9270       IF(MINT(12).EQ.22) THEN
9271          MINT(16)=22
9272          VINT(308)=VINT(4)**2
9273       ENDIF
9274       MINT(103)=MINT(11)
9275       MINT(104)=MINT(12)
9276  
9277 C...Choice of process type - first event of pileup.
9278       INMULT=0
9279       IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9280       ELSEIF(MINT(82).EQ.1) THEN
9281  
9282 C...For gamma-p or gamma-gamma first pick between alternatives.
9283         IGA=0
9284         IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9285         MINT(122)=IGA
9286  
9287 C...For real gamma + gamma with different nature, flip at random.
9288         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9289      &  MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9290           MINTSV=MINT(41)
9291           MINT(41)=MINT(42)
9292           MINT(42)=MINTSV
9293           MINTSV=MINT(45)
9294           MINT(45)=MINT(46)
9295           MINT(46)=MINTSV
9296           MINTSV=MINT(107)
9297           MINT(107)=MINT(108)
9298           MINT(108)=MINTSV
9299           IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9300         ENDIF
9301  
9302 C...Pick process type, possibly by user process machinery.
9303 C...(If the latter, also event will be picked here.)
9304         IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9305           CALL UPEVNT
9306           CALL PYUPRE
9307         ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9308           CALL UPEVNT
9309           CALL PYUPRE
9310           ISUB=0
9311   110     ISUB=ISUB+1
9312           IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9313      &    ISUB.LT.500) GOTO 110
9314         ELSE
9315           RSUB=XSEC(0,1)*PYR(0)
9316           DO 120 I=1,500
9317             IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9318             ISUB=I
9319             RSUB=RSUB-XSEC(I,1)
9320             IF(RSUB.LE.0D0) GOTO 130
9321   120     CONTINUE
9322   130     IF(ISUB.EQ.95) ISUB=96
9323           IF(ISUB.EQ.96) INMULT=1
9324           IF(ISET(ISUB).EQ.11) THEN
9325             IDPRUP=KFPR(ISUB,2)
9326             CALL UPEVNT
9327             CALL PYUPRE
9328           ENDIF
9329         ENDIF
9330  
9331 C...Choice of inclusive process type - pileup events.
9332       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9333         RSUB=VINT(131)*PYR(0)
9334         ISUB=96
9335         IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9336         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9337         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9338         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9339      &  ISUB=91
9340         IF(ISUB.EQ.96) INMULT=1
9341       ENDIF
9342  
9343 C...Choice of photon energy and flux factor inside lepton.
9344       IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9345         CALL PYGAGA(3,WTGAGA)
9346         IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9347           CKIN(3)=MAX(VINT(285),VINT(154))
9348           CKIN(1)=2D0*CKIN(3)
9349         ENDIF
9350 C...When necessary set direct/resolved photon by hand.
9351       ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9352         IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9353         IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9354       ENDIF
9355  
9356 C...Restrict direct*resolved processes to pTmin >= Q,
9357 C...to avoid doublecounting  with DIS.
9358       IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9359         IF(MINT(15).EQ.22) THEN
9360           CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9361         ELSE
9362           CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9363         ENDIF
9364         CKIN(1)=2D0*CKIN(3)
9365       ENDIF
9366  
9367 C...Set up for multiple interactions (may include impact parameter).
9368       IF(INMULT.EQ.1) THEN
9369         IF(MINT(35).LE.1) CALL PYMULT(2)
9370         IF(MINT(35).GE.2) CALL PYMIGN(2)
9371       ENDIF
9372  
9373 C...Loopback point for minimum bias in photon physics.
9374       LOOP2=0
9375   140 LOOP2=LOOP2+1
9376       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9377       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9378       IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9379      &NGEN(97,1)=NGEN(97,1)+MINT(143)
9380       MINT(1)=ISUB
9381       ISTSB=ISET(ISUB)
9382  
9383 C...Random choice of flavour for some SUSY processes.
9384       IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9385 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9386         IF(ISUB.EQ.210) THEN
9387           KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9388           KFPR(ISUB,2)=KFPR(ISUB,1)+1
9389 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9390         ELSEIF(ISUB.EQ.213) THEN
9391           KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9392           KFPR(ISUB,2)=KFPR(ISUB,1)
9393 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9394         ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9395      &  ISUB.NE.257) THEN
9396           IF(ISUB.GE.258) THEN
9397             RKF=4D0
9398           ELSE
9399             RKF=5D0
9400           ENDIF
9401           IF(MOD(ISUB,2).EQ.0) THEN
9402             KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9403           ELSE
9404             KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9405           ENDIF
9406 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9407         ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9408           IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9409             KSU1=KSUSY1
9410             KSU2=KSUSY1
9411           ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9412             KSU1=KSUSY2
9413             KSU2=KSUSY2
9414           ELSEIF(PYR(0).LT.0.5D0) THEN
9415             KSU1=KSUSY1
9416             KSU2=KSUSY2
9417           ELSE
9418             KSU1=KSUSY2
9419             KSU2=KSUSY1
9420           ENDIF
9421           KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9422           KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9423 C...~q ~q(bar);  ~q = ~d, ~u, ~s, or ~c.
9424         ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9425           KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9426           KFPR(ISUB,2)=KFPR(ISUB,1)
9427         ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9428           KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9429           KFPR(ISUB,2)=KFPR(ISUB,1)
9430 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9431         ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9432           IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9433             KSU1=KSUSY1
9434             KSU2=KSUSY1
9435           ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9436             KSU1=KSUSY2
9437             KSU2=KSUSY2
9438           ELSEIF(PYR(0).LT.0.5D0) THEN
9439             KSU1=KSUSY1
9440             KSU2=KSUSY2
9441           ELSE
9442             KSU1=KSUSY2
9443             KSU2=KSUSY1
9444           ENDIF
9445           IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9446             RKF=5D0
9447           ELSE
9448             RKF=4D0
9449           ENDIF
9450           KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9451         ENDIF
9452       ENDIF
9453  
9454 C...Random choice of flavours for some UED processes
9455 c...The production processes can generate a doublet pair,
9456 c...a singlet pair, or a doublet + singlet.
9457       IF(ISUB.EQ.313)THEN
9458 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9459          IF(PYR(0).LE.0.1)THEN
9460             KFPR(ISUB,1)=5100001
9461          ELSE
9462             KFPR(ISUB,1)=5100002
9463          ENDIF
9464          KFPR(ISUB,2)=KFPR(ISUB,1)
9465       ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9466 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9467 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9468          IF(PYR(0).LE.0.1)THEN
9469             KFPR(ISUB,1)=5100001
9470          ELSE
9471             KFPR(ISUB,1)=5100002
9472          ENDIF
9473          KFPR(ISUB,2)=-KFPR(ISUB,1)
9474       ELSEIF(ISUB.EQ.316)THEN
9475 C...qi + qbarj -> q*_Di + q*_Sbarj
9476          IF(PYR(0).LE.0.5)THEN
9477             KFPR(ISUB,1)=5100001
9478 c Changed from private pythia6410_ued code
9479 c            KFPR(ISUB,2)=-5010001
9480             KFPR(ISUB,2)=-6100002
9481          ELSE
9482             KFPR(ISUB,1)=5100002
9483 c Changed from private pythia6410_ued code
9484 c            KFPR(ISUB,2)=-5010002
9485             KFPR(ISUB,2)=-6100001
9486          ENDIF
9487       ELSEIF(ISUB.EQ.317)THEN
9488 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9489          IF(PYR(0).LE.0.5)THEN
9490             KFPR(ISUB,1)=5100001
9491             KFPR(ISUB,2)=-5100002
9492          ELSE
9493             KFPR(ISUB,1)=5100002
9494             KFPR(ISUB,2)=-5100001
9495          ENDIF
9496       ELSEIF(ISUB.EQ.318)THEN
9497 C...qi + qj -> q*_Di + q*_Sj
9498          IF(PYR(0).LE.0.5)THEN
9499             KFPR(ISUB,1)=5100001
9500             KFPR(ISUB,2)=6100002
9501          ELSE
9502             KFPR(ISUB,1)=5100002
9503             KFPR(ISUB,2)=6100001
9504          ENDIF
9505       ENDIF
9506 
9507 C...Find resonances (explicit or implicit in cross-section).
9508       MINT(72)=0
9509       KFR1=0
9510       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9511         KFR1=KFPR(ISUB,1)
9512       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9513      &  ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9514         KFR1=23
9515       ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9516      &  ISUB.EQ.177) THEN
9517         KFR1=24
9518       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9519         KFR1=25
9520         IF(MSTP(46).EQ.5) THEN
9521           KFR1=89
9522           PMAS(89,1)=PARP(45)
9523           PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9524         ENDIF
9525       ELSEIF(ISUB.EQ.481) THEN
9526         KFR1=9900001
9527       ENDIF
9528       CKMX=CKIN(2)
9529       IF(CKMX.LE.0D0) CKMX=VINT(1)
9530       KCR1=PYCOMP(KFR1)
9531       IF(KCR1.EQ.0) KFR1=0
9532       IF(KFR1.NE.0) THEN
9533         IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9534      &  CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9535       ENDIF
9536       IF(KFR1.NE.0) THEN
9537         TAUR1=PMAS(KCR1,1)**2/VINT(2)
9538         GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9539         MINT(72)=1
9540         MINT(73)=KFR1
9541         VINT(73)=TAUR1
9542         VINT(74)=GAMR1
9543       ENDIF
9544       KFR2=0
9545       KFR3=0
9546       IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9547      $(ISUB.GE.361.AND.ISUB.LE.380))
9548      $THEN
9549         KFR2=23
9550         IF(ISUB.EQ.141) THEN
9551           KCR2=PYCOMP(KFR2)
9552           IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9553      &     CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9554             KFR2=0
9555           ELSE
9556             TAUR2=PMAS(KCR2,1)**2/VINT(2)            
9557             GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9558             MINT(72)=2
9559             MINT(74)=KFR2
9560             VINT(75)=TAUR2
9561             VINT(76)=GAMR2
9562           ENDIF
9563 C...3 resonances at work:   rho, omega, a
9564         ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9565      &     .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9566           MINT(72)=IRES
9567           IF(IRES.GE.1) THEN
9568             VINT(73)=XMAS(1)**2/VINT(2)
9569             VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9570             TAUR1=VINT(73)
9571             GAMR1=VINT(74)
9572             KFR1=1
9573           ENDIF
9574           IF(IRES.GE.2) THEN
9575             VINT(75)=XMAS(2)**2/VINT(2)
9576             VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9577             TAUR2=VINT(75)
9578             GAMR2=VINT(76)
9579             KFR2=2
9580           ENDIF
9581           IF(IRES.EQ.3) THEN
9582             VINT(77)=XMAS(3)**2/VINT(2)
9583             VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9584             TAUR3=VINT(77)
9585             GAMR3=VINT(78)
9586             KFR3=3
9587           ENDIF
9588 C...Charged current:  rho+- and a+-
9589         ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9590           MINT(72)=IRES
9591           IF(JRES.GE.1) THEN
9592             VINT(73)=YMAS(1)**2/VINT(2)
9593             VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9594             KFR1=1
9595             TAUR1=VINT(73)
9596             GAMR1=VINT(74)
9597           ENDIF
9598           IF(JRES.GE.2) THEN
9599             VINT(75)=YMAS(2)**2/VINT(2)
9600             VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9601             KFR2=2
9602             TAUR2=VINT(73)
9603             GAMR2=VINT(74)
9604           ENDIF
9605           KFR3=0
9606         ENDIF
9607         IF(ISUB.NE.141) THEN
9608           IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9609 
9610           ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9611             MINT(72)=2
9612           ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9613             MINT(72)=2
9614             MINT(74)=KFR3
9615             VINT(75)=TAUR3
9616             VINT(76)=GAMR3
9617           ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9618             MINT(72)=2
9619             MINT(73)=KFR2
9620             VINT(73)=TAUR2
9621             VINT(74)=GAMR2
9622             MINT(74)=KFR3
9623             VINT(75)=TAUR3
9624             VINT(76)=GAMR3
9625           ELSEIF(KFR1.NE.0) THEN
9626             MINT(72)=1
9627           ELSEIF(KFR2.NE.0) THEN
9628             MINT(72)=1
9629             MINT(73)=KFR2
9630             VINT(73)=TAUR2
9631             VINT(74)=GAMR2
9632           ELSEIF(KFR3.NE.0) THEN
9633             MINT(72)=1
9634             MINT(73)=KFR3
9635             VINT(73)=TAUR3
9636             VINT(74)=GAMR3
9637           ELSE
9638             MINT(72)=0
9639           ENDIF
9640         ELSE
9641           IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9642 
9643           ELSEIF(KFR2.NE.0) THEN
9644             KFR1=KFR2
9645             TAUR1=TAUR2
9646             GAMR1=GAMR2
9647             MINT(72)=1
9648             MINT(73)=KFR1
9649             VINT(73)=TAUR1
9650             VINT(74)=GAMR1
9651             KFR2=0
9652           ELSE
9653             MINT(72)=0
9654           ENDIF
9655         ENDIF
9656       ENDIF
9657  
9658 C...Find product masses and minimum pT of process,
9659 C...optionally with broadening according to a truncated Breit-Wigner.
9660       VINT(63)=0D0
9661       VINT(64)=0D0
9662       MINT(71)=0
9663       VINT(71)=CKIN(3)
9664       IF(MINT(82).GE.2) VINT(71)=0D0
9665       VINT(80)=1D0
9666       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9667         NBW=0
9668         DO 160 I=1,2
9669           PMMN(I)=0D0
9670           IF(KFPR(ISUB,I).EQ.0) THEN
9671           ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9672      &      PARP(41)) THEN
9673             VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9674           ELSE
9675             NBW=NBW+1
9676 C...This prevents SUSY/t particles from becoming too light.
9677             KFLW=KFPR(ISUB,I)
9678             IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9679               KCW=PYCOMP(KFLW)
9680               PMMN(I)=PMAS(KCW,1)
9681               DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9682                 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9683                   PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9684      &            PMAS(PYCOMP(KFDP(IDC,2)),1)
9685                   IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9686      &            PMAS(PYCOMP(KFDP(IDC,3)),1)
9687                   PMMN(I)=MIN(PMMN(I),PMSUM)
9688                 ENDIF
9689   150         CONTINUE
9690             ELSEIF(KFLW.EQ.6) THEN
9691               PMMN(I)=PMAS(24,1)+PMAS(5,1)
9692             ENDIF
9693           ENDIF
9694   160   CONTINUE
9695         IF(NBW.GE.1) THEN
9696           CKIN41=CKIN(41)
9697           CKIN43=CKIN(43)
9698           CKIN(41)=MAX(PMMN(1),CKIN(41))
9699           CKIN(43)=MAX(PMMN(2),CKIN(43))
9700           CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9701           CKIN(41)=CKIN41
9702           CKIN(43)=CKIN43
9703           IF(MINT(51).EQ.1) THEN
9704             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9705             IF(MFAIL.EQ.1) THEN
9706               MSTI(61)=1
9707               RETURN
9708             ENDIF
9709             GOTO 100
9710           ENDIF
9711           VINT(63)=PQM3**2
9712           VINT(64)=PQM4**2
9713         ENDIF
9714         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9715         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9716       ENDIF
9717  
9718 C...Prepare for additional variable choices in 2 -> 3.
9719       IF(ISTSB.EQ.5) THEN
9720         VINT(201)=0D0
9721         IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9722         VINT(206)=VINT(201)
9723         IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9724         VINT(204)=PMAS(23,1)
9725         IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9726      &   VINT(204)=PMAS(24,1) 
9727         IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9728         IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9729      &    ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9730      &         VINT(204)=VINT(201)
9731         VINT(209)=VINT(204)
9732           IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9733       ENDIF
9734  
9735 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9736       IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9737      &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9738         VRN=PYR(0)*SIGT(0,0,5)
9739         IF(MINT(101).LE.1) THEN
9740           I1MN=0
9741           I1MX=0
9742         ELSE
9743           I1MN=1
9744           I1MX=MINT(101)
9745         ENDIF
9746         IF(MINT(102).LE.1) THEN
9747           I2MN=0
9748           I2MX=0
9749         ELSE
9750           I2MN=1
9751           I2MX=MINT(102)
9752         ENDIF
9753         DO 180 I1=I1MN,I1MX
9754           KFV1=110*I1+3
9755           DO 170 I2=I2MN,I2MX
9756             KFV2=110*I2+3
9757             VRN=VRN-SIGT(I1,I2,5)
9758             IF(VRN.LE.0D0) GOTO 190
9759   170     CONTINUE
9760   180   CONTINUE
9761   190   IF(MINT(101).GE.2) MINT(103)=KFV1
9762         IF(MINT(102).GE.2) MINT(104)=KFV2
9763       ENDIF
9764  
9765       IF(ISTSB.EQ.0) THEN
9766 C...Elastic scattering or single or double diffractive scattering.
9767  
9768 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9769         MINT(103)=MINT(11)
9770         MINT(104)=MINT(12)
9771         PMM(1)=VINT(3)
9772         PMM(2)=VINT(4)
9773         IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9774           JJ=ISUB-90
9775           VRN=PYR(0)*SIGT(0,0,JJ)
9776           IF(MINT(101).LE.1) THEN
9777             I1MN=0
9778             I1MX=0
9779           ELSE
9780             I1MN=1
9781             I1MX=MINT(101)
9782           ENDIF
9783           IF(MINT(102).LE.1) THEN
9784             I2MN=0
9785             I2MX=0
9786           ELSE
9787             I2MN=1
9788             I2MX=MINT(102)
9789           ENDIF
9790           DO 210 I1=I1MN,I1MX
9791             KFV1=110*I1+3
9792             DO 200 I2=I2MN,I2MX
9793               KFV2=110*I2+3
9794               VRN=VRN-SIGT(I1,I2,JJ)
9795               IF(VRN.LE.0D0) GOTO 220
9796   200       CONTINUE
9797   210     CONTINUE
9798   220     IF(MINT(101).GE.2) THEN
9799             MINT(103)=KFV1
9800             PMM(1)=PYMASS(KFV1)
9801           ENDIF
9802           IF(MINT(102).GE.2) THEN
9803             MINT(104)=KFV2
9804             PMM(2)=PYMASS(KFV2)
9805           ENDIF
9806         ENDIF
9807         VINT(67)=PMM(1)
9808         VINT(68)=PMM(2)
9809  
9810 C...Select mass for GVMD states (rejecting previous assignment).
9811         Q0S=4D0*PARP(15)**2
9812         Q1S=4D0*VINT(154)**2
9813         LOOP3=0
9814   230   LOOP3=LOOP3+1
9815         DO 240 JT=1,2
9816           IF(MINT(106+JT).EQ.3) THEN
9817             PS=VINT(2+JT)**2
9818             PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9819      &      (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9820             IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9821      &      PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9822           ENDIF
9823   240   CONTINUE
9824         IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9825           IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9826      &    GOTO 230
9827           GOTO 100
9828         ENDIF
9829  
9830 C...Side/sides of diffractive system.
9831         MINT(17)=0
9832         MINT(18)=0
9833         IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9834         IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9835  
9836 C...Find masses of particles and minimal masses of diffractive states.
9837         DO 250 JT=1,2
9838           PDIF(JT)=PMM(JT)
9839           VINT(68+JT)=PDIF(JT)
9840           IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9841   250   CONTINUE
9842         SH=VINT(2)
9843         SQM1=PMM(1)**2
9844         SQM2=PMM(2)**2
9845         SQM3=PDIF(1)**2
9846         SQM4=PDIF(2)**2
9847         SMRES1=(PMM(1)+PMRC)**2
9848         SMRES2=(PMM(2)+PMRC)**2
9849  
9850 C...Find elastic slope and lower limit diffractive slope.
9851         IHA=MAX(2,IABS(MINT(103))/110)
9852         IF(IHA.GE.5) IHA=1
9853         IHB=MAX(2,IABS(MINT(104))/110)
9854         IF(IHB.GE.5) IHB=1
9855         IF(ISUB.EQ.91) THEN
9856           BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9857         ELSEIF(ISUB.EQ.92) THEN
9858           BMN=MAX(2D0,2D0*BHAD(IHB))
9859         ELSEIF(ISUB.EQ.93) THEN
9860           BMN=MAX(2D0,2D0*BHAD(IHA))
9861         ELSEIF(ISUB.EQ.94) THEN
9862           BMN=2D0*ALP*4D0
9863         ENDIF
9864  
9865 C...Determine maximum possible t range and coefficient of generation.
9866         SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9867         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9868         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9869         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9870         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9871      &  (SQM1*SQM4-SQM2*SQM3)/SH
9872         THL=-0.5D0*(THA+THB)
9873         THU=THC/THL
9874         THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9875  
9876 C...Select diffractive mass/masses according to dm^2/m^2.
9877         LOOP3=0
9878   260   LOOP3=LOOP3+1
9879         DO 270 JT=1,2
9880           IF(MINT(16+JT).EQ.0) THEN
9881             PDIF(2+JT)=PDIF(JT)
9882           ELSE
9883             PMMIN=PDIF(JT)
9884             PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9885             PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9886           ENDIF
9887   270   CONTINUE
9888         SQM3=PDIF(3)**2
9889         SQM4=PDIF(4)**2
9890  
9891 C..Additional mass factors, including resonance enhancement.
9892         IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9893           IF(LOOP3.LT.100) GOTO 260
9894           GOTO 100
9895         ENDIF
9896         IF(ISUB.EQ.92) THEN
9897           FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9898           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9899         ELSEIF(ISUB.EQ.93) THEN
9900           FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9901           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9902         ELSEIF(ISUB.EQ.94) THEN
9903           FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9904      &    (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9905      &    (1D0+CRES*SMRES2/(SMRES2+SQM4))
9906           IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9907         ENDIF
9908  
9909 C...Select t according to exp(Bmn*t) and correct to right slope.
9910         TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9911         IF(ISUB.GE.92) THEN
9912           IF(ISUB.EQ.92) THEN
9913             BADD=2D0*ALP*LOG(SH/SQM3)
9914             IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9915           ELSEIF(ISUB.EQ.93) THEN
9916             BADD=2D0*ALP*LOG(SH/SQM4)
9917             IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9918           ELSEIF(ISUB.EQ.94) THEN
9919             BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9920           ENDIF
9921           IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9922         ENDIF
9923  
9924 C...Check whether m^2 and t choices are consistent.
9925         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9926         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9927         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9928         IF(THB.LE.1D-8) GOTO 260
9929         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9930      &  (SQM1*SQM4-SQM2*SQM3)/SH
9931         THLM=-0.5D0*(THA+THB)
9932         THUM=THC/THLM
9933         IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9934  
9935 C...Information to output.
9936         VINT(21)=1D0
9937         VINT(22)=0D0
9938         VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9939         VINT(45)=TH
9940         VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9941         VINT(63)=PDIF(3)**2
9942         VINT(64)=PDIF(4)**2
9943         VINT(283)=PMM(1)**2/4D0
9944         VINT(284)=PMM(2)**2/4D0
9945  
9946 C...Note: in the following, by In is meant the integral over the
9947 C...quantity multiplying coefficient cn.
9948 C...Choose tau according to h1(tau)/tau, where
9949 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9950 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9951 C...I1/I5*c5*1/(tau+tau_R') +
9952 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9953 C...I1/I7*c7*tau/(1.-tau), and
9954 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9955       ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9956         CALL PYKLIM(1)
9957         IF(MINT(51).NE.0) THEN
9958           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9959           IF(MFAIL.EQ.1) THEN
9960             MSTI(61)=1
9961             RETURN
9962           ENDIF
9963           GOTO 100
9964         ENDIF
9965         RTAU=PYR(0)
9966         MTAU=1
9967         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9968         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9969         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9970         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9971      &  MTAU=5
9972         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9973      &  COEF(ISUB,5)) MTAU=6
9974         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9975      &  COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9976 C...Additional check to handle techni-processes with extra resonance
9977 C....Only modify tau treatment
9978         IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9979      &   THEN
9980           IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9981      &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9982           IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9983      &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9984      &     +COEFX(ISUB,1)) MTAU=9
9985         ENDIF
9986         CALL PYKMAP(1,MTAU,PYR(0))
9987  
9988 C...2 -> 3, 4 processes:
9989 C...Choose tau' according to h4(tau,tau')/tau', where
9990 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9991 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9992         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9993           CALL PYKLIM(4)
9994           IF(MINT(51).NE.0) THEN
9995             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9996             IF(MFAIL.EQ.1) THEN
9997               MSTI(61)=1
9998               RETURN
9999             ENDIF
10000             GOTO 100
10001           ENDIF
10002           RTAUP=PYR(0)
10003           MTAUP=1
10004           IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
10005           IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
10006           CALL PYKMAP(4,MTAUP,PYR(0))
10007         ENDIF
10008  
10009 C...Choose y* according to h2(y*), where
10010 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
10011 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
10012 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
10013 C...and c1 + c2 + c3 + c4 + c5 = 1.
10014         CALL PYKLIM(2)
10015         IF(MINT(51).NE.0) THEN
10016           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10017           IF(MFAIL.EQ.1) THEN
10018             MSTI(61)=1
10019             RETURN
10020           ENDIF
10021           GOTO 100
10022         ENDIF
10023         RYST=PYR(0)
10024         MYST=1
10025         IF(RYST.GT.COEF(ISUB,8)) MYST=2
10026         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10027         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
10028         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
10029      &  COEF(ISUB,11)) MYST=5
10030         CALL PYKMAP(2,MYST,PYR(0))
10031  
10032 C...2 -> 2 processes:
10033 C...Choose cos(theta-hat) (cth) according to h3(cth), where
10034 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
10035 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
10036 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
10037 C...and c0 + c1 + c2 + c3 + c4 = 1.
10038         CALL PYKLIM(3)
10039         IF(MINT(51).NE.0) THEN
10040           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10041           IF(MFAIL.EQ.1) THEN
10042             MSTI(61)=1
10043             RETURN
10044           ENDIF
10045           GOTO 100
10046         ENDIF
10047         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
10048           RCTH=PYR(0)
10049           MCTH=1
10050           IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
10051           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
10052           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
10053           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
10054      &    COEF(ISUB,16)) MCTH=5
10055           CALL PYKMAP(3,MCTH,PYR(0))
10056         ENDIF
10057  
10058 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
10059         IF(ISTSB.EQ.5) THEN
10060           CALL PYKMAP(5,0,0D0)
10061           IF(MINT(51).NE.0) THEN
10062             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10063             IF(MFAIL.EQ.1) THEN
10064               MSTI(61)=1
10065               RETURN
10066             ENDIF
10067             GOTO 100
10068           ENDIF
10069         ENDIF
10070  
10071 C...DIS as f + gamma* -> f process: set dummy values.
10072       ELSEIF(ISTSB.EQ.8) THEN
10073         VINT(21)=0.9D0
10074         VINT(22)=0D0
10075         VINT(23)=0D0
10076         VINT(47)=0D0
10077         VINT(48)=0D0
10078  
10079 C...Low-pT or multiple interactions (first semihard interaction).
10080       ELSEIF(ISTSB.EQ.9) THEN
10081         IF(MINT(35).LE.1) CALL PYMULT(3)
10082         IF(MINT(35).GE.2) CALL PYMIGN(3)
10083         ISUB=MINT(1)
10084  
10085 C...Study user-defined process: kinematics plus weight.
10086       ELSEIF(ISTSB.EQ.11) THEN
10087         IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
10088      &  PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
10089         MSTI(51)=0
10090         IF(NUP.LE.0) THEN
10091           MINT(51)=2
10092           MSTI(51)=1
10093           IF(MINT(82).EQ.1) THEN
10094             NGEN(0,1)=NGEN(0,1)-1
10095             NGEN(ISUB,1)=NGEN(ISUB,1)-1
10096           ENDIF
10097           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10098           RETURN
10099         ENDIF
10100  
10101 C...Extract cross section event weight.
10102         IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
10103           SIGS=1D-9*XWGTUP
10104         ELSE
10105           SIGS=1D-9*XSECUP(KFPR(ISUB,1))
10106         ENDIF
10107         IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10108           VINT(97)=SIGN(1D0,XWGTUP)
10109         ELSE
10110           VINT(97)=1D-9*XWGTUP
10111         ENDIF
10112  
10113 C...Construct 'trivial' kinematical variables needed.
10114         KFL1=IDUP(1)
10115         KFL2=IDUP(2)
10116         VINT(41)=PUP(4,1)/EBMUP(1)
10117         VINT(42)=PUP(4,2)/EBMUP(2)
10118         IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10119           CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10120      &        '(listing follows):') 
10121           CALL PYLIST(7)
10122         ENDIF
10123         VINT(21)=VINT(41)*VINT(42)
10124         VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10125         VINT(44)=VINT(21)*VINT(2)
10126         VINT(43)=SQRT(MAX(0D0,VINT(44)))
10127         VINT(55)=SCALUP
10128         IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10129         VINT(56)=VINT(55)**2
10130         VINT(57)=AQEDUP
10131         VINT(58)=AQCDUP
10132  
10133 C...Construct other kinematical variables needed (approximately).
10134         VINT(23)=0D0
10135         VINT(26)=VINT(21)
10136         VINT(45)=-0.5D0*VINT(44)
10137         VINT(46)=-0.5D0*VINT(44)
10138         VINT(49)=VINT(43)
10139         VINT(50)=VINT(44)
10140         VINT(51)=VINT(55)
10141         VINT(52)=VINT(56)
10142         VINT(53)=VINT(55)
10143         VINT(54)=VINT(56)
10144         VINT(25)=0D0
10145         VINT(48)=0D0
10146         IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10147      &  '(PYRAND:) unacceptable ISTUP code for incoming particles')
10148         DO 280 IUP=3,NUP
10149           IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10150      &    '(PYRAND:) unacceptable ISTUP code for particles')
10151           IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10152      &    PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10153           IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10154      &    PUP(2,IUP)**2)
10155   280   CONTINUE
10156         VINT(47)=SQRT(VINT(48))
10157       ENDIF
10158  
10159 C...Choose azimuthal angle.
10160       VINT(24)=0D0
10161       IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10162  
10163 C...Check against user cuts on kinematics at parton level.
10164       MINT(51)=0
10165       IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10166       IF(MINT(51).NE.0) THEN
10167         IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10168         IF(MFAIL.EQ.1) THEN
10169           MSTI(61)=1
10170           RETURN
10171         ENDIF
10172         GOTO 100
10173       ENDIF
10174       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10175         MCUT=0
10176         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10177      &  CALL PYKCUT(MCUT)
10178         IF(MCUT.NE.0) THEN
10179           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10180           IF(MFAIL.EQ.1) THEN
10181             MSTI(61)=1
10182             RETURN
10183           ENDIF
10184           GOTO 100
10185         ENDIF
10186       ENDIF
10187  
10188       IF(ISTSB.LE.10) THEN
10189 C...  If internal process, call PYSIGH
10190         CALL PYSIGH(NCHN,SIGS)
10191       ELSE
10192 C...  If external process, still have to set MI starting scale 
10193         IF (MSTP(86).EQ.1) THEN
10194 C...  Limit phase space by xT2 of hard interaction
10195 C...  (gives undercounting of MI when ext proc != dijets)
10196           XT2GMX = VINT(25)
10197         ELSE
10198 C...  All accessible phase space allowed
10199 C...  (gives double counting of MI when ext proc = dijets)
10200           XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10201         ENDIF
10202         VINT(62)=0.25D0*XT2GMX*VINT(2)
10203         VINT(61)=SQRT(MAX(0D0,VINT(62)))
10204       ENDIF
10205       
10206       SIGSOR=SIGS
10207       SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10208  
10209 C...Multiply cross section by lepton -> photon flux factor.
10210       IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10211         SIGS=WTGAGA*SIGS
10212         DO 290 ICHN=1,NCHN
10213           SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10214   290   CONTINUE
10215         SIGLPT=WTGAGA*SIGLPT
10216       ENDIF
10217  
10218 C...Multiply cross-section by user-defined weights.
10219       IF(MSTP(173).EQ.1) THEN
10220         SIGS=PARP(173)*SIGS
10221         DO 300 ICHN=1,NCHN
10222           SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10223   300   CONTINUE
10224         SIGLPT=PARP(173)*SIGLPT
10225       ENDIF
10226       WTXS=1D0
10227       SIGSWT=SIGS
10228       VINT(99)=1D0
10229       VINT(100)=1D0
10230       IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10231         IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10232      &  MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10233         SIGSWT=WTXS*SIGS
10234         VINT(99)=WTXS
10235         IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10236       ENDIF
10237  
10238 C...Calculations for Monte Carlo estimate of all cross-sections.
10239       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10240         IF(MSTP(142).LE.1) THEN
10241           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10242         ELSE
10243           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10244         ENDIF
10245       ELSEIF(MINT(82).EQ.1) THEN
10246         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10247       ENDIF
10248       IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10249      &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10250  
10251 C...Multiple interactions: store results of cross-section calculation.
10252       IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10253         VINT(153)=SIGSOR
10254         IF(MINT(35).LE.1) CALL PYMULT(4)
10255         IF(MINT(35).GE.2) CALL PYMIGN(4)
10256       ENDIF
10257  
10258 C...Ratio of actual to maximum cross section.
10259       IF(ISTSB.NE.11) THEN
10260         VIOL=SIGSWT/XSEC(ISUB,1)
10261         IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10262       ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10263         VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10264       ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10265         VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10266       ELSE
10267         VIOL=1D0
10268       ENDIF
10269  
10270 C...Check that weight not negative.
10271       IF(MSTP(123).LE.0) THEN
10272         IF(VIOL.LT.-1D-3) THEN
10273           WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10274           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10275      &    VINT(22),VINT(23),VINT(26)
10276           CALL PYSTOP(2)
10277         ENDIF
10278       ELSE
10279         IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10280           VINT(109)=VIOL
10281           IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10282           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10283      &    VINT(22),VINT(23),VINT(26)
10284         ENDIF
10285       ENDIF
10286  
10287 C...Weighting using estimate of maximum of differential cross-section.
10288       RATND=1D0
10289       IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10290         IF(VIOL.LT.PYR(0)) THEN
10291           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10292           IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10293           GOTO 100
10294         ENDIF
10295       ELSEIF(MFAIL.EQ.0) THEN
10296         RATND=SIGLPT/XSEC(95,1)
10297         VIOL=VIOL/RATND
10298         IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10299           IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10300      &    (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10301           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10302           ISUB=0
10303           GOTO 100
10304         ENDIF
10305         IF(VIOL.LT.PYR(0)) THEN
10306           GOTO 140
10307         ENDIF
10308       ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10309         IF(VIOL.LT.PYR(0)) THEN
10310           MSTI(61)=1
10311           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10312           RETURN
10313         ENDIF
10314       ELSE
10315         RATND=SIGLPT/XSEC(95,1)
10316         IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10317           MSTI(61)=1
10318           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10319           RETURN
10320         ENDIF
10321         VIOL=VIOL/RATND
10322         IF(VIOL.LT.PYR(0)) THEN
10323           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10324           GOTO 100
10325         ENDIF
10326       ENDIF
10327  
10328 C...Check for possible violation of estimated maximum of differential
10329 C...cross-section used in weighting.
10330       IF(MSTP(123).LE.0) THEN
10331         IF(VIOL.GT.1D0) THEN
10332           WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10333           IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10334      &    VINT(22),VINT(23),VINT(26)
10335           CALL PYSTOP(2)
10336         ENDIF
10337       ELSEIF(MSTP(123).EQ.1) THEN
10338         IF(VIOL.GT.VINT(108)) THEN
10339           VINT(108)=VIOL
10340           IF(VIOL.GT.1.0001D0) THEN
10341             MINT(10)=1
10342             WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10343             IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10344      &      VINT(22),VINT(23),VINT(26)
10345           ENDIF
10346         ENDIF
10347       ELSEIF(VIOL.GT.VINT(108)) THEN
10348         VINT(108)=VIOL
10349         IF(VIOL.GT.1D0) THEN
10350           MINT(10)=1
10351           IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10352           IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10353      &    THEN
10354             XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10355             IF(KFPR(ISUB,1).LE.9) THEN
10356               IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10357      &        XMAXUP(KFPR(ISUB,1))
10358             ELSEIF(KFPR(ISUB,1).LE.99) THEN
10359               IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10360      &        XMAXUP(KFPR(ISUB,1))
10361             ELSE
10362               IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10363      &        XMAXUP(KFPR(ISUB,1))
10364             ENDIF
10365           ENDIF
10366           IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10367             XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10368             XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10369             IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10370      &      XSEC(0,1)=XSEC(0,1)+XDIF
10371             IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10372      &      VINT(22),VINT(23),VINT(26)
10373             IF(ISUB.LE.9) THEN
10374               IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10375             ELSEIF(ISUB.LE.99) THEN
10376               IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10377             ELSE
10378               IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10379             ENDIF
10380           ENDIF
10381           VINT(108)=1D0
10382         ENDIF
10383       ENDIF
10384  
10385 C...Multiple interactions: choose impact parameter (if not already done).
10386       IF(MINT(39).EQ.0) VINT(148)=1D0
10387       IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10388      &MSTP(82).GE.3) THEN
10389         IF(MINT(35).LE.1) CALL PYMULT(5)
10390         IF(MINT(35).GE.2) CALL PYMIGN(5)
10391         IF(VINT(150).LT.PYR(0)) THEN
10392           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10393           IF(MFAIL.EQ.1) THEN
10394             MSTI(61)=1
10395             RETURN
10396           ENDIF
10397           GOTO 100
10398         ENDIF
10399       ENDIF
10400       IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10401       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10402         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10403         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10404       ENDIF
10405       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10406  
10407 C...Choose flavour of reacting partons (and subprocess).
10408       IF(ISTSB.GE.11) GOTO 320
10409       RSIGS=SIGS*PYR(0)
10410       QT2=VINT(48)
10411       RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10412      &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10413       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10414      &PYR(0).GT.RQQBAR)) THEN
10415         DO 310 ICHN=1,NCHN
10416           KFL1=ISIG(ICHN,1)
10417           KFL2=ISIG(ICHN,2)
10418           MINT(2)=ISIG(ICHN,3)
10419           RSIGS=RSIGS-SIGH(ICHN)
10420           IF(RSIGS.LE.0D0) GOTO 320
10421   310   CONTINUE
10422  
10423 C...Multiple interactions: choose qqbar preferentially at small pT.
10424       ELSEIF(ISUB.EQ.96) THEN
10425         MINT(105)=MINT(103)
10426         MINT(109)=MINT(107)
10427         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10428         MINT(105)=MINT(104)
10429         MINT(109)=MINT(108)
10430         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10431         MINT(1)=11
10432         MINT(2)=1
10433         IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10434  
10435 C...Low-pT: choose string drawing configuration.
10436       ELSE
10437         KFL1=21
10438         KFL2=21
10439         RSIGS=6D0*PYR(0)
10440         MINT(2)=1
10441         IF(RSIGS.GT.1D0) MINT(2)=2
10442         IF(RSIGS.GT.2D0) MINT(2)=3
10443       ENDIF
10444  
10445 C...Reassign QCD process. Partons before initial state radiation.
10446   320 IF(MINT(2).GT.10) THEN
10447         MINT(1)=MINT(2)/10
10448         MINT(2)=MOD(MINT(2),10)
10449       ENDIF
10450       IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10451      &NGEN(MINT(1),2)+1
10452       MINT(15)=KFL1
10453       MINT(16)=KFL2
10454       MINT(13)=MINT(15)
10455       MINT(14)=MINT(16)
10456       VINT(141)=VINT(41)
10457       VINT(142)=VINT(42)
10458       VINT(151)=0D0
10459       VINT(152)=0D0
10460  
10461 C...Calculate x value of photon for parton inside photon inside e.
10462       DO 350 JT=1,2
10463         MINT(18+JT)=0
10464         VINT(154+JT)=0D0
10465         MSPLI=0
10466         IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10467         IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10468         IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10469         IF(MSPLI.EQ.2) THEN
10470           KFLH=MINT(14+JT)
10471           XHRD=VINT(140+JT)
10472           Q2HRD=VINT(54)
10473           MINT(105)=MINT(102+JT)
10474           MINT(109)=MINT(106+JT)
10475           VINT(120)=VINT(2+JT)
10476           IF(MSTP(57).LE.1) THEN
10477             CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10478           ELSE
10479             CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10480           ENDIF
10481           WTMX=4D0*XPQ(KFLH)
10482           IF(MSTP(13).EQ.2) THEN
10483             Q2PMS=Q2HRD/PMAS(11,1)**2
10484             WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10485           ENDIF
10486   330     XE=XHRD**PYR(0)
10487           XG=MIN(1D0-1D-10,XHRD/XE)
10488           IF(MSTP(57).LE.1) THEN
10489             CALL PYPDFU(22,XG,Q2HRD,XPQ)
10490           ELSE
10491             CALL PYPDFL(22,XG,Q2HRD,XPQ)
10492           ENDIF
10493           WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10494           IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10495           IF(WT.LT.PYR(0)*WTMX) GOTO 330
10496           MINT(18+JT)=1
10497           VINT(154+JT)=XE
10498           DO 340 KFLS=-25,25
10499             XSFX(JT,KFLS)=XPQ(KFLS)
10500   340     CONTINUE
10501         ENDIF
10502   350 CONTINUE
10503  
10504 C...Pick scale where photon is resolved.
10505       Q0S=PARP(15)**2
10506       Q1S=VINT(154)**2
10507       VINT(283)=0D0
10508       IF(MINT(107).EQ.3) THEN
10509         IF(MSTP(66).EQ.1) THEN
10510           VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10511         ELSEIF(MSTP(66).EQ.2) THEN
10512           PS=VINT(3)**2
10513           Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10514      &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10515           Q2INT=SQRT(Q0S*Q2EFF)
10516           VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10517         ELSEIF(MSTP(66).EQ.3) THEN
10518           VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10519         ELSEIF(MSTP(66).GE.4) THEN
10520           PS=0.25D0*VINT(3)**2
10521           VINT(283)=(Q0S+PS)*(Q1S+PS)/
10522      &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10523         ENDIF
10524       ENDIF
10525       VINT(284)=0D0
10526       IF(MINT(108).EQ.3) THEN
10527         IF(MSTP(66).EQ.1) THEN
10528           VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10529         ELSEIF(MSTP(66).EQ.2) THEN
10530           PS=VINT(4)**2
10531           Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10532      &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10533           Q2INT=SQRT(Q0S*Q2EFF)
10534           VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10535         ELSEIF(MSTP(66).EQ.3) THEN
10536           VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10537         ELSEIF(MSTP(66).GE.4) THEN
10538           PS=0.25D0*VINT(4)**2
10539           VINT(284)=(Q0S+PS)*(Q1S+PS)/
10540      &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10541         ENDIF
10542       ENDIF
10543       IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10544  
10545 C...Format statements for differential cross-section maximum violations.
10546  5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10547      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10548  5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10549      &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10550  5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10551      &'in event',1X,I7)
10552  5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10553      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10554  5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10555      &'in event',1X,I7)
10556  5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10557  5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10558  5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10559  5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10560  5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10561  6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10562 
10563       RETURN
10564       END
10565  
10566 C*********************************************************************
10567  
10568 C...PYSCAT
10569 C...Finds outgoing flavours and event type; sets up the kinematics
10570 C...and colour flow of the hard scattering
10571  
10572       SUBROUTINE PYSCAT
10573  
10574 C...Double precision and integer declarations
10575       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10576       IMPLICIT INTEGER(I-N)
10577       INTEGER PYK,PYCHGE,PYCOMP
10578 C...Parameter statement to help give large particle numbers.
10579       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10580      &KEXCIT=4000000,KDIMEN=5000000)
10581 C...Parameter statement for maximum size of showers.
10582       PARAMETER (MAXNUR=1000)
10583  
10584 C...User process event common block.
10585       INTEGER MAXNUP
10586       PARAMETER (MAXNUP=500)
10587       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10588       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10589       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10590      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10591      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10592       SAVE /HEPEUP/
10593  
10594 C...Commonblocks.
10595       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10596       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10597       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10598       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10599       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10600       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10601       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10602       COMMON/PYINT1/MINT(400),VINT(400)
10603       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10604       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10605       COMMON/PYINT4/MWID(500),WIDS(500,5)
10606       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10607       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10608      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10609       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10610       COMMON/PYPUED/IUED(0:99),RUED(0:99)
10611       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10612      &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10613      &/PYTCSM/,/PYPUED/
10614 C...Local arrays and saved variables
10615       DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10616      &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10617       INTEGER IOKFLA(6),IIFLAV
10618 C...UED related declarations:
10619 C...equivalences between ordered particles (451->475)
10620 C...and UED particle code (5 000 000 + id)
10621       DIMENSION IUEDEQ(475),MUED(2)
10622       DATA (IUEDEQ(I),I=451,475)/
10623      & 6100001,6100002,6100003,6100004,6100005,6100006, 
10624      & 5100001,5100002,5100003,5100004,5100005,5100006, 
10625      & 6100011,6100013,6100015,                         
10626      & 5100012,5100011,5100014,5100013,5100016,5100015, 
10627      & 5100021,5100022,5100023,5100024/                 
10628       SAVE VINTSV
10629  
10630 C...Read out process
10631       ISUB=MINT(1)
10632       ISUBSV=ISUB
10633  
10634 C...Restore information for low-pT processes
10635       IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10636         DO 100 J=41,66
10637   100   VINT(J)=VINTSV(J)
10638       ENDIF
10639  
10640 C...Convert H' or A process into equivalent H one
10641       IHIGG=1
10642       KFHIGG=25
10643       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10644      &ISUB.LE.190)) THEN
10645         IHIGG=2
10646         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10647         KFHIGG=33+IHIGG
10648         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10649         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10650         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10651         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10652         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10653         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10654         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10655         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10656         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10657         IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10658         IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10659         IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10660       ENDIF
10661  
10662       IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10663  
10664 C...Convert bottomonium process into equivalent charmonium ones.
10665       IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10666  
10667 C...Choice of subprocess, number of documentation lines
10668       IDOC=6+ISET(ISUB)
10669       IF(ISUB.EQ.95) IDOC=8
10670       IF(ISET(ISUB).EQ.5) IDOC=9
10671       IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10672       MINT(3)=IDOC-6
10673       IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10674       MINT(4)=IDOC
10675       IPU1=MINT(84)+1
10676       IPU2=MINT(84)+2
10677       IPU3=MINT(84)+3
10678       IPU4=MINT(84)+4
10679       IPU5=MINT(84)+5
10680       IPU6=MINT(84)+6
10681  
10682 C...Reset K, P and V vectors. Store incoming particles
10683       DO 120 JT=1,MSTP(126)+100
10684         I=MINT(83)+JT
10685         IF(I.GT.MSTU(4)) GOTO 120
10686         DO 110 J=1,5
10687           K(I,J)=0
10688           P(I,J)=0D0
10689           V(I,J)=0D0
10690   110   CONTINUE
10691   120 CONTINUE
10692       DO 140 JT=1,2
10693         I=MINT(83)+JT
10694         K(I,1)=21
10695         K(I,2)=MINT(10+JT)
10696         DO 130 J=1,5
10697           P(I,J)=VINT(285+5*JT+J)
10698   130   CONTINUE
10699   140 CONTINUE
10700       MINT(6)=2
10701       KFRES=0
10702  
10703 C...Store incoming partons in their CM-frame. Save pdf value.
10704       SH=VINT(44)
10705       SHR=SQRT(SH)
10706       SHP=VINT(26)*VINT(2)
10707       SHPR=SQRT(SHP)
10708       SHUSER=SHR
10709       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10710       DO 150 JT=1,2
10711         I=MINT(84)+JT
10712         K(I,1)=14
10713         K(I,2)=MINT(14+JT)
10714         K(I,3)=MINT(83)+2+JT
10715         P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10716         P(I,4)=0.5D0*SHUSER
10717         IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10718          VINT(38+JT)=XSFX(JT,MINT(14+JT))
10719         ELSE
10720          VINT(38+JT)=1D0
10721         ENDIF
10722   150 CONTINUE
10723  
10724 C...Copy incoming partons to documentation lines
10725       DO 170 JT=1,2
10726         I1=MINT(83)+4+JT
10727         I2=MINT(84)+JT
10728         K(I1,1)=21
10729         K(I1,2)=K(I2,2)
10730         K(I1,3)=I1-2
10731         DO 160 J=1,5
10732           P(I1,J)=P(I2,J)
10733   160   CONTINUE
10734   170 CONTINUE
10735  
10736 C...Choose new quark/lepton flavour for relevant annihilation graphs
10737       IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10738      &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10739      &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10740         IGLGA=21
10741         IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10742         CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10743   180   RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10744         DO 190 I=1,MDCY(IGLGA,3)
10745           KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10746           RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10747           IF(RKFL.LE.0D0) GOTO 200
10748   190   CONTINUE
10749   200   CONTINUE
10750         IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10751      &      .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10752           IF(KFLF.GE.4) GOTO 180
10753         ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10754      &       OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10755           KFLF=4
10756           MINT(2)=MINT(2)-2
10757         ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10758      &        OR.ISUB.EQ.316) THEN
10759           KFLF=5
10760           MINT(2)=MINT(2)-4
10761         ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10762      &  .AND.IABS(KFLF).GE.3) THEN
10763           FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10764      &    VINT(44)**2
10765           FACCIB=VINT(46)**2/RTCM(41)**4
10766           IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10767         ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10768           KFLF=5
10769           MINT(2)=1
10770         ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10771           IF(KFLF.EQ.5) GOTO 180
10772         ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10773           IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10774         ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10775           IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10776         ENDIF
10777       ENDIF
10778  
10779 C...Final state flavours and colour flow: default values
10780       JS=1
10781       MINT(21)=MINT(15)
10782       MINT(22)=MINT(16)
10783       MINT(23)=0
10784       MINT(24)=0
10785       KCC=20
10786       KCS=ISIGN(1,MINT(15))
10787  
10788       IF(ISET(ISUB).EQ.11) THEN
10789 C...User-defined processes: find products
10790         MINT(3)=0
10791         DO 210 IUP=3,NUP
10792           IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10793           ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10794             MINT(21+IUP)=IDUP(IUP)
10795           ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10796      &    ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10797           ELSEIF(IDUP(IUP).EQ.0) THEN
10798           ELSE
10799             MINT(3)=MINT(3)+1
10800             IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10801           ENDIF
10802   210   CONTINUE
10803  
10804       ELSEIF(ISUB.LE.10) THEN
10805         IF(ISUB.EQ.1) THEN
10806 C...f + fbar -> gamma*/Z0
10807           KFRES=23
10808  
10809         ELSEIF(ISUB.EQ.2) THEN
10810 C...f + fbar' -> W+/-
10811           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10812           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10813           KFRES=ISIGN(24,KCH1+KCH2)
10814  
10815         ELSEIF(ISUB.EQ.3) THEN
10816 C...f + fbar -> h0 (or H0, or A0)
10817           KFRES=KFHIGG
10818  
10819         ELSEIF(ISUB.EQ.4) THEN
10820 C...gamma + W+/- -> W+/-
10821  
10822         ELSEIF(ISUB.EQ.5) THEN
10823 C...Z0 + Z0 -> h0
10824           XH=SH/SHP
10825           MINT(21)=MINT(15)
10826           MINT(22)=MINT(16)
10827           PMQ(1)=PYMASS(MINT(21))
10828           PMQ(2)=PYMASS(MINT(22))
10829   220     JT=INT(1.5D0+PYR(0))
10830           ZMIN=2D0*PMQ(JT)/SHPR
10831           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10832      &    (SHPR*(SHPR-PMQ(3-JT)))
10833           ZMAX=MIN(1D0-XH,ZMAX)
10834           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10835           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10836      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10837           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10838           IF(SQC1.LT.1D-8) GOTO 220
10839           C1=SQRT(SQC1)
10840           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10841           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10842           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10843           Z(3-JT)=1D0-XH/(1D0-Z(JT))
10844           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10845           IF(SQC1.LT.1D-8) GOTO 220
10846           C1=SQRT(SQC1)
10847           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10848           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10849           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10850           PHIR=PARU(2)*PYR(0)
10851           CPHI=COS(PHIR)
10852           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10853      &    SQRT(1D0-CTHE(2)**2)*CPHI
10854           Z1=2D0-Z(JT)
10855           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10856           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10857           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10858      &    PMQ(3-JT)**2/SHP))
10859           ZMIN=2D0*PMQ(3-JT)/SHPR
10860           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10861           ZMAX=MIN(1D0-XH,ZMAX)
10862           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10863           KCC=22
10864           KFRES=25
10865  
10866         ELSEIF(ISUB.EQ.6) THEN
10867 C...Z0 + W+/- -> W+/-
10868  
10869         ELSEIF(ISUB.EQ.7) THEN
10870 C...W+ + W- -> Z0
10871  
10872         ELSEIF(ISUB.EQ.8) THEN
10873 C...W+ + W- -> h0
10874           XH=SH/SHP
10875   230     DO 260 JT=1,2
10876             I=MINT(14+JT)
10877             IA=IABS(I)
10878             IF(IA.LE.10) THEN
10879               RVCKM=VINT(180+I)*PYR(0)
10880               DO 240 J=1,MSTP(1)
10881                 IB=2*J-1+MOD(IA,2)
10882                 IPM=(5-ISIGN(1,I))/2
10883                 IDC=J+MDCY(IA,2)+2
10884                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10885                 MINT(20+JT)=ISIGN(IB,I)
10886                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10887                 IF(RVCKM.LE.0D0) GOTO 250
10888   240         CONTINUE
10889             ELSE
10890               IB=2*((IA+1)/2)-1+MOD(IA,2)
10891               MINT(20+JT)=ISIGN(IB,I)
10892             ENDIF
10893   250       PMQ(JT)=PYMASS(MINT(20+JT))
10894   260     CONTINUE
10895           JT=INT(1.5D0+PYR(0))
10896           ZMIN=2D0*PMQ(JT)/SHPR
10897           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10898      &    (SHPR*(SHPR-PMQ(3-JT)))
10899           ZMAX=MIN(1D0-XH,ZMAX)
10900           IF(ZMIN.GE.ZMAX) GOTO 230
10901           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10902           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10903      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10904           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10905           IF(SQC1.LT.1D-8) GOTO 230
10906           C1=SQRT(SQC1)
10907           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10908           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10909           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10910           Z(3-JT)=1D0-XH/(1D0-Z(JT))
10911           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10912           IF(SQC1.LT.1D-8) GOTO 230
10913           C1=SQRT(SQC1)
10914           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10915           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10916           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10917           PHIR=PARU(2)*PYR(0)
10918           CPHI=COS(PHIR)
10919           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10920      &    SQRT(1D0-CTHE(2)**2)*CPHI
10921           Z1=2D0-Z(JT)
10922           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10923           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10924           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10925      &    PMQ(3-JT)**2/SHP))
10926           ZMIN=2D0*PMQ(3-JT)/SHPR
10927           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10928           ZMAX=MIN(1D0-XH,ZMAX)
10929           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10930           KCC=22
10931           KFRES=25
10932  
10933         ELSEIF(ISUB.EQ.10) THEN
10934 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10935           IF(MINT(2).EQ.1) THEN
10936             KCC=22
10937           ELSE
10938 C...W exchange: need to mix flavours according to CKM matrix
10939             DO 280 JT=1,2
10940               I=MINT(14+JT)
10941               IA=IABS(I)
10942               IF(IA.LE.10) THEN
10943                 RVCKM=VINT(180+I)*PYR(0)
10944                 DO 270 J=1,MSTP(1)
10945                   IB=2*J-1+MOD(IA,2)
10946                   IPM=(5-ISIGN(1,I))/2
10947                   IDC=J+MDCY(IA,2)+2
10948                   IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10949                   MINT(20+JT)=ISIGN(IB,I)
10950                   RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10951                   IF(RVCKM.LE.0D0) GOTO 280
10952   270           CONTINUE
10953               ELSE
10954                 IB=2*((IA+1)/2)-1+MOD(IA,2)
10955                 MINT(20+JT)=ISIGN(IB,I)
10956               ENDIF
10957   280       CONTINUE
10958             KCC=22
10959           ENDIF
10960         ENDIF
10961  
10962       ELSEIF(ISUB.LE.20) THEN
10963         IF(ISUB.EQ.11) THEN
10964 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10965           KCC=MINT(2)
10966           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10967  
10968         ELSEIF(ISUB.EQ.12) THEN
10969 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10970           MINT(21)=ISIGN(KFLF,MINT(15))
10971           MINT(22)=-MINT(21)
10972           KCC=4
10973  
10974         ELSEIF(ISUB.EQ.13) THEN
10975 C...f + fbar -> g + g; th arbitrary
10976           MINT(21)=21
10977           MINT(22)=21
10978           KCC=MINT(2)+4
10979  
10980         ELSEIF(ISUB.EQ.14) THEN
10981 C...f + fbar -> g + gamma; th arbitrary
10982           IF(PYR(0).GT.0.5D0) JS=2
10983           MINT(20+JS)=21
10984           MINT(23-JS)=22
10985           KCC=17+JS
10986  
10987         ELSEIF(ISUB.EQ.15) THEN
10988 C...f + fbar -> g + Z0; th arbitrary
10989           IF(PYR(0).GT.0.5D0) JS=2
10990           MINT(20+JS)=21
10991           MINT(23-JS)=23
10992           KCC=17+JS
10993  
10994         ELSEIF(ISUB.EQ.16) THEN
10995 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10996           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10997           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10998           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10999           MINT(20+JS)=21
11000           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11001           KCC=17+JS
11002  
11003         ELSEIF(ISUB.EQ.17) THEN
11004 C...f + fbar -> g + h0; th arbitrary
11005           IF(PYR(0).GT.0.5D0) JS=2
11006           MINT(20+JS)=21
11007           MINT(23-JS)=25
11008           KCC=17+JS
11009  
11010         ELSEIF(ISUB.EQ.18) THEN
11011 C...f + fbar -> gamma + gamma; th arbitrary
11012           MINT(21)=22
11013           MINT(22)=22
11014  
11015         ELSEIF(ISUB.EQ.19) THEN
11016 C...f + fbar -> gamma + Z0; th arbitrary
11017           IF(PYR(0).GT.0.5D0) JS=2
11018           MINT(20+JS)=22
11019           MINT(23-JS)=23
11020  
11021         ELSEIF(ISUB.EQ.20) THEN
11022 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
11023 C...(p(fbar')-p(W+))**2
11024           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11025           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11026           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11027           MINT(20+JS)=22
11028           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11029         ENDIF
11030  
11031       ELSEIF(ISUB.LE.30) THEN
11032         IF(ISUB.EQ.21) THEN
11033 C...f + fbar -> gamma + h0; th arbitrary
11034           IF(PYR(0).GT.0.5D0) JS=2
11035           MINT(20+JS)=22
11036           MINT(23-JS)=25
11037  
11038         ELSEIF(ISUB.EQ.22) THEN
11039 C...f + fbar -> Z0 + Z0; th arbitrary
11040           MINT(21)=23
11041           MINT(22)=23
11042  
11043         ELSEIF(ISUB.EQ.23) THEN
11044 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11045           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11046           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11047           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11048           MINT(20+JS)=23
11049           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11050  
11051         ELSEIF(ISUB.EQ.24) THEN
11052 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
11053           IF(PYR(0).GT.0.5D0) JS=2
11054           MINT(20+JS)=23
11055           MINT(23-JS)=KFHIGG
11056  
11057         ELSEIF(ISUB.EQ.25) THEN
11058 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
11059           MINT(21)=-ISIGN(24,MINT(15))
11060           MINT(22)=-MINT(21)
11061  
11062         ELSEIF(ISUB.EQ.26) THEN
11063 C...f + fbar' -> W+/- + h0 (or H0, or A0);
11064 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11065           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11066           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11067           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11068           MINT(20+JS)=ISIGN(24,KCH1+KCH2)
11069           MINT(23-JS)=KFHIGG
11070  
11071         ELSEIF(ISUB.EQ.27) THEN
11072 C...f + fbar -> h0 + h0
11073  
11074         ELSEIF(ISUB.EQ.28) THEN
11075 C...f + g -> f + g; th = (p(f)-p(f))**2
11076           IF(MINT(15).EQ.21) JS=2
11077           KCC=MINT(2)+6
11078           IF(MINT(15).EQ.21) KCC=KCC+2
11079           IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11080           IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11081  
11082         ELSEIF(ISUB.EQ.29) THEN
11083 C...f + g -> f + gamma; th = (p(f)-p(f))**2
11084           IF(MINT(15).EQ.21) JS=2
11085           MINT(23-JS)=22
11086           KCC=15+JS
11087           KCS=ISIGN(1,MINT(14+JS))
11088  
11089         ELSEIF(ISUB.EQ.30) THEN
11090 C...f + g -> f + Z0; th = (p(f)-p(f))**2
11091           IF(MINT(15).EQ.21) JS=2
11092           MINT(23-JS)=23
11093           KCC=15+JS
11094           KCS=ISIGN(1,MINT(14+JS))
11095         ENDIF
11096  
11097       ELSEIF(ISUB.LE.40) THEN
11098         IF(ISUB.EQ.31) THEN
11099 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
11100           IF(MINT(15).EQ.21) JS=2
11101           I=MINT(14+JS)
11102           IA=IABS(I)
11103           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11104           RVCKM=VINT(180+I)*PYR(0)
11105           DO 290 J=1,MSTP(1)
11106             IB=2*J-1+MOD(IA,2)
11107             IPM=(5-ISIGN(1,I))/2
11108             IDC=J+MDCY(IA,2)+2
11109             IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11110             MINT(20+JS)=ISIGN(IB,I)
11111             RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11112             IF(RVCKM.LE.0D0) GOTO 300
11113   290     CONTINUE
11114   300     KCC=15+JS
11115           KCS=ISIGN(1,MINT(14+JS))
11116  
11117         ELSEIF(ISUB.EQ.32) THEN
11118 C...f + g -> f + h0; th = (p(f)-p(f))**2
11119           IF(MINT(15).EQ.21) JS=2
11120           MINT(23-JS)=25
11121           KCC=15+JS
11122           KCS=ISIGN(1,MINT(14+JS))
11123  
11124         ELSEIF(ISUB.EQ.33) THEN
11125 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11126           IF(MINT(15).EQ.22) JS=2
11127           MINT(23-JS)=21
11128           KCC=24+JS
11129           KCS=ISIGN(1,MINT(14+JS))
11130  
11131         ELSEIF(ISUB.EQ.34) THEN
11132 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11133           IF(MINT(15).EQ.22) JS=2
11134           KCC=22
11135           KCS=ISIGN(1,MINT(14+JS))
11136  
11137         ELSEIF(ISUB.EQ.35) THEN
11138 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11139           IF(MINT(15).EQ.22) JS=2
11140           MINT(23-JS)=23
11141           KCC=22
11142  
11143         ELSEIF(ISUB.EQ.36) THEN
11144 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11145           IF(MINT(15).EQ.22) JS=2
11146           I=MINT(14+JS)
11147           IA=IABS(I)
11148           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11149           IF(IA.LE.10) THEN
11150             RVCKM=VINT(180+I)*PYR(0)
11151             DO 310 J=1,MSTP(1)
11152               IB=2*J-1+MOD(IA,2)
11153               IPM=(5-ISIGN(1,I))/2
11154               IDC=J+MDCY(IA,2)+2
11155               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11156               MINT(20+JS)=ISIGN(IB,I)
11157               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11158               IF(RVCKM.LE.0D0) GOTO 320
11159   310       CONTINUE
11160           ELSE
11161             IB=2*((IA+1)/2)-1+MOD(IA,2)
11162             MINT(20+JS)=ISIGN(IB,I)
11163           ENDIF
11164   320     KCC=22
11165  
11166         ELSEIF(ISUB.EQ.37) THEN
11167 C...f + gamma -> f + h0
11168  
11169         ELSEIF(ISUB.EQ.38) THEN
11170 C...f + Z0 -> f + g
11171  
11172         ELSEIF(ISUB.EQ.39) THEN
11173 C...f + Z0 -> f + gamma
11174  
11175         ELSEIF(ISUB.EQ.40) THEN
11176 C...f + Z0 -> f + Z0
11177         ENDIF
11178  
11179       ELSEIF(ISUB.LE.50) THEN
11180         IF(ISUB.EQ.41) THEN
11181 C...f + Z0 -> f' + W+/-
11182  
11183         ELSEIF(ISUB.EQ.42) THEN
11184 C...f + Z0 -> f + h0
11185  
11186         ELSEIF(ISUB.EQ.43) THEN
11187 C...f + W+/- -> f' + g
11188  
11189         ELSEIF(ISUB.EQ.44) THEN
11190 C...f + W+/- -> f' + gamma
11191  
11192         ELSEIF(ISUB.EQ.45) THEN
11193 C...f + W+/- -> f' + Z0
11194  
11195         ELSEIF(ISUB.EQ.46) THEN
11196 C...f + W+/- -> f' + W+/-
11197  
11198         ELSEIF(ISUB.EQ.47) THEN
11199 C...f + W+/- -> f' + h0
11200  
11201         ELSEIF(ISUB.EQ.48) THEN
11202 C...f + h0 -> f + g
11203  
11204         ELSEIF(ISUB.EQ.49) THEN
11205 C...f + h0 -> f + gamma
11206  
11207         ELSEIF(ISUB.EQ.50) THEN
11208 C...f + h0 -> f + Z0
11209         ENDIF
11210  
11211       ELSEIF(ISUB.LE.60) THEN
11212         IF(ISUB.EQ.51) THEN
11213 C...f + h0 -> f' + W+/-
11214  
11215         ELSEIF(ISUB.EQ.52) THEN
11216 C...f + h0 -> f + h0
11217  
11218         ELSEIF(ISUB.EQ.53) THEN
11219 C...g + g -> f + fbar; th arbitrary
11220           KCS=(-1)**INT(1.5D0+PYR(0))
11221           MINT(21)=ISIGN(KFLF,KCS)
11222           MINT(22)=-MINT(21)
11223           KCC=MINT(2)+10
11224  
11225         ELSEIF(ISUB.EQ.54) THEN
11226 C...g + gamma -> f + fbar; th arbitrary
11227           KCS=(-1)**INT(1.5D0+PYR(0))
11228           MINT(21)=ISIGN(KFLF,KCS)
11229           MINT(22)=-MINT(21)
11230           KCC=27
11231           IF(MINT(16).EQ.21) KCC=28
11232  
11233         ELSEIF(ISUB.EQ.55) THEN
11234 C...g + Z0 -> f + fbar
11235  
11236         ELSEIF(ISUB.EQ.56) THEN
11237 C...g + W+/- -> f + fbar'
11238  
11239         ELSEIF(ISUB.EQ.57) THEN
11240 C...g + h0 -> f + fbar
11241  
11242         ELSEIF(ISUB.EQ.58) THEN
11243 C...gamma + gamma -> f + fbar; th arbitrary
11244           KCS=(-1)**INT(1.5D0+PYR(0))
11245           MINT(21)=ISIGN(KFLF,KCS)
11246           MINT(22)=-MINT(21)
11247           KCC=21
11248  
11249         ELSEIF(ISUB.EQ.59) THEN
11250 C...gamma + Z0 -> f + fbar
11251  
11252         ELSEIF(ISUB.EQ.60) THEN
11253 C...gamma + W+/- -> f + fbar'
11254         ENDIF
11255  
11256       ELSEIF(ISUB.LE.70) THEN
11257         IF(ISUB.EQ.61) THEN
11258 C...gamma + h0 -> f + fbar
11259  
11260         ELSEIF(ISUB.EQ.62) THEN
11261 C...Z0 + Z0 -> f + fbar
11262  
11263         ELSEIF(ISUB.EQ.63) THEN
11264 C...Z0 + W+/- -> f + fbar'
11265  
11266         ELSEIF(ISUB.EQ.64) THEN
11267 C...Z0 + h0 -> f + fbar
11268  
11269         ELSEIF(ISUB.EQ.65) THEN
11270 C...W+ + W- -> f + fbar
11271  
11272         ELSEIF(ISUB.EQ.66) THEN
11273 C...W+/- + h0 -> f + fbar'
11274  
11275         ELSEIF(ISUB.EQ.67) THEN
11276 C...h0 + h0 -> f + fbar
11277  
11278         ELSEIF(ISUB.EQ.68) THEN
11279 C...g + g -> g + g; th arbitrary
11280           KCC=MINT(2)+12
11281           KCS=(-1)**INT(1.5D0+PYR(0))
11282  
11283         ELSEIF(ISUB.EQ.69) THEN
11284 C...gamma + gamma -> W+ + W-; th arbitrary
11285           MINT(21)=24
11286           MINT(22)=-24
11287           KCC=21
11288  
11289         ELSEIF(ISUB.EQ.70) THEN
11290 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11291           IF(MINT(15).EQ.22) MINT(21)=23
11292           IF(MINT(16).EQ.22) MINT(22)=23
11293           KCC=21
11294         ENDIF
11295  
11296       ELSEIF(ISUB.LE.80) THEN
11297         IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11298 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11299           XH=SH/SHP
11300           MINT(21)=MINT(15)
11301           MINT(22)=MINT(16)
11302           PMQ(1)=PYMASS(MINT(21))
11303           PMQ(2)=PYMASS(MINT(22))
11304   330     JT=INT(1.5D0+PYR(0))
11305           ZMIN=2D0*PMQ(JT)/SHPR
11306           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11307      &    (SHPR*(SHPR-PMQ(3-JT)))
11308           ZMAX=MIN(1D0-XH,ZMAX)
11309           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11310           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11311      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11312           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11313           IF(SQC1.LT.1D-8) GOTO 330
11314           C1=SQRT(SQC1)
11315           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11316           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11317           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11318           Z(3-JT)=1D0-XH/(1D0-Z(JT))
11319           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11320           IF(SQC1.LT.1D-8) GOTO 330
11321           C1=SQRT(SQC1)
11322           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11323           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11324           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11325           PHIR=PARU(2)*PYR(0)
11326           CPHI=COS(PHIR)
11327           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11328      &    SQRT(1D0-CTHE(2)**2)*CPHI
11329           Z1=2D0-Z(JT)
11330           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11331           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11332           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11333      &    PMQ(3-JT)**2/SHP))
11334           ZMIN=2D0*PMQ(3-JT)/SHPR
11335           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11336           ZMAX=MIN(1D0-XH,ZMAX)
11337           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11338           KCC=22
11339  
11340         ELSEIF(ISUB.EQ.73) THEN
11341 C...Z0 + W+/- -> Z0 + W+/-
11342           JS=MINT(2)
11343           XH=SH/SHP
11344   340     JT=3-MINT(2)
11345           I=MINT(14+JT)
11346           IA=IABS(I)
11347           IF(IA.LE.10) THEN
11348             RVCKM=VINT(180+I)*PYR(0)
11349             DO 350 J=1,MSTP(1)
11350               IB=2*J-1+MOD(IA,2)
11351               IPM=(5-ISIGN(1,I))/2
11352               IDC=J+MDCY(IA,2)+2
11353               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11354               MINT(20+JT)=ISIGN(IB,I)
11355               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11356               IF(RVCKM.LE.0D0) GOTO 360
11357   350       CONTINUE
11358           ELSE
11359             IB=2*((IA+1)/2)-1+MOD(IA,2)
11360             MINT(20+JT)=ISIGN(IB,I)
11361           ENDIF
11362   360     PMQ(JT)=PYMASS(MINT(20+JT))
11363           MINT(23-JT)=MINT(17-JT)
11364           PMQ(3-JT)=PYMASS(MINT(23-JT))
11365           JT=INT(1.5D0+PYR(0))
11366           ZMIN=2D0*PMQ(JT)/SHPR
11367           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11368      &    (SHPR*(SHPR-PMQ(3-JT)))
11369           ZMAX=MIN(1D0-XH,ZMAX)
11370           IF(ZMIN.GE.ZMAX) GOTO 340
11371           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11372           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11373      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11374           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11375           IF(SQC1.LT.1D-8) GOTO 340
11376           C1=SQRT(SQC1)
11377           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11378           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11379           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11380           Z(3-JT)=1D0-XH/(1D0-Z(JT))
11381           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11382           IF(SQC1.LT.1D-8) GOTO 340
11383           C1=SQRT(SQC1)
11384           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11385           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11386           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11387           PHIR=PARU(2)*PYR(0)
11388           CPHI=COS(PHIR)
11389           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11390      &    SQRT(1D0-CTHE(2)**2)*CPHI
11391           Z1=2D0-Z(JT)
11392           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11393           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11394           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11395      &    PMQ(3-JT)**2/SHP))
11396           ZMIN=2D0*PMQ(3-JT)/SHPR
11397           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11398           ZMAX=MIN(1D0-XH,ZMAX)
11399           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11400           KCC=22
11401  
11402         ELSEIF(ISUB.EQ.74) THEN
11403 C...Z0 + h0 -> Z0 + h0
11404  
11405         ELSEIF(ISUB.EQ.75) THEN
11406 C...W+ + W- -> gamma + gamma
11407  
11408         ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11409 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11410           XH=SH/SHP
11411   370     DO 400 JT=1,2
11412             I=MINT(14+JT)
11413             IA=IABS(I)
11414             IF(IA.LE.10) THEN
11415               RVCKM=VINT(180+I)*PYR(0)
11416               DO 380 J=1,MSTP(1)
11417                 IB=2*J-1+MOD(IA,2)
11418                 IPM=(5-ISIGN(1,I))/2
11419                 IDC=J+MDCY(IA,2)+2
11420                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11421                 MINT(20+JT)=ISIGN(IB,I)
11422                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11423                 IF(RVCKM.LE.0D0) GOTO 390
11424   380         CONTINUE
11425             ELSE
11426               IB=2*((IA+1)/2)-1+MOD(IA,2)
11427               MINT(20+JT)=ISIGN(IB,I)
11428             ENDIF
11429   390       PMQ(JT)=PYMASS(MINT(20+JT))
11430   400     CONTINUE
11431           JT=INT(1.5D0+PYR(0))
11432           ZMIN=2D0*PMQ(JT)/SHPR
11433           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11434      &    (SHPR*(SHPR-PMQ(3-JT)))
11435           ZMAX=MIN(1D0-XH,ZMAX)
11436           IF(ZMIN.GE.ZMAX) GOTO 370
11437           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11438           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11439      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11440           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11441           IF(SQC1.LT.1D-8) GOTO 370
11442           C1=SQRT(SQC1)
11443           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11444           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11445           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11446           Z(3-JT)=1D0-XH/(1D0-Z(JT))
11447           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11448           IF(SQC1.LT.1D-8) GOTO 370
11449           C1=SQRT(SQC1)
11450           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11451           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11452           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11453           PHIR=PARU(2)*PYR(0)
11454           CPHI=COS(PHIR)
11455           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11456      &    SQRT(1D0-CTHE(2)**2)*CPHI
11457           Z1=2D0-Z(JT)
11458           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11459           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11460           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11461      &    PMQ(3-JT)**2/SHP))
11462           ZMIN=2D0*PMQ(3-JT)/SHPR
11463           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11464           ZMAX=MIN(1D0-XH,ZMAX)
11465           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11466           KCC=22
11467  
11468         ELSEIF(ISUB.EQ.78) THEN
11469 C...W+/- + h0 -> W+/- + h0
11470  
11471         ELSEIF(ISUB.EQ.79) THEN
11472 C...h0 + h0 -> h0 + h0
11473  
11474         ELSEIF(ISUB.EQ.80) THEN
11475 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11476           IF(MINT(15).EQ.22) JS=2
11477           I=MINT(14+JS)
11478           IA=IABS(I)
11479           MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11480           IB=3-IA
11481           MINT(20+JS)=ISIGN(IB,I)
11482           KCC=22
11483         ENDIF
11484  
11485       ELSEIF(ISUB.LE.90) THEN
11486         IF(ISUB.EQ.81) THEN
11487 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11488           MINT(21)=ISIGN(MINT(55),MINT(15))
11489           MINT(22)=-MINT(21)
11490           KCC=4
11491  
11492         ELSEIF(ISUB.EQ.82) THEN
11493 C...g + g -> Q + Qbar; th arbitrary
11494           KCS=(-1)**INT(1.5D0+PYR(0))
11495           MINT(21)=ISIGN(MINT(55),KCS)
11496           MINT(22)=-MINT(21)
11497           KCC=MINT(2)+10
11498  
11499         ELSEIF(ISUB.EQ.83) THEN
11500 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11501           KFOLD=MINT(16)
11502           IF(MINT(2).EQ.2) KFOLD=MINT(15)
11503           KFAOLD=IABS(KFOLD)
11504           IF(KFAOLD.GT.10) THEN
11505             KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11506           ELSE
11507             RCKM=VINT(180+KFOLD)*PYR(0)
11508             IPM=(5-ISIGN(1,KFOLD))/2
11509             KFANEW=-MOD(KFAOLD+1,2)
11510   410       KFANEW=KFANEW+2
11511             IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11512             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11513               IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11514      &        VCKM(KFAOLD/2,(KFANEW+1)/2)
11515               IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11516      &        VCKM(KFANEW/2,(KFAOLD+1)/2)
11517             ENDIF
11518             IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11519           ENDIF
11520           IF(MINT(2).EQ.1) THEN
11521             MINT(21)=ISIGN(MINT(55),MINT(15))
11522             MINT(22)=ISIGN(KFANEW,MINT(16))
11523           ELSE
11524             MINT(21)=ISIGN(KFANEW,MINT(15))
11525             MINT(22)=ISIGN(MINT(55),MINT(16))
11526             JS=2
11527           ENDIF
11528           KCC=22
11529  
11530         ELSEIF(ISUB.EQ.84) THEN
11531 C...g + gamma -> Q + Qbar; th arbitary
11532           KCS=(-1)**INT(1.5D0+PYR(0))
11533           MINT(21)=ISIGN(MINT(55),KCS)
11534           MINT(22)=-MINT(21)
11535           KCC=27
11536           IF(MINT(16).EQ.21) KCC=28
11537  
11538         ELSEIF(ISUB.EQ.85) THEN
11539 C...gamma + gamma -> F + Fbar; th arbitary
11540           KCS=(-1)**INT(1.5D0+PYR(0))
11541           MINT(21)=ISIGN(MINT(56),KCS)
11542           MINT(22)=-MINT(21)
11543           KCC=21
11544  
11545         ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11546 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11547           MINT(21)=KFPR(ISUB,1)
11548           MINT(22)=KFPR(ISUB,2)
11549           KCC=24
11550           KCS=(-1)**INT(1.5D0+PYR(0))
11551         ENDIF
11552  
11553       ELSEIF(ISUB.LE.100) THEN
11554         IF(ISUB.EQ.95) THEN
11555 C...Low-pT ( = energyless g + g -> g + g)
11556           KCC=MINT(2)+12
11557           KCS=(-1)**INT(1.5D0+PYR(0))
11558  
11559         ELSEIF(ISUB.EQ.96) THEN
11560 C...Multiple interactions (should be reassigned to QCD process)
11561         ENDIF
11562  
11563       ELSEIF(ISUB.LE.110) THEN
11564         IF(ISUB.EQ.101) THEN
11565 C...g + g -> gamma*/Z0
11566           KCC=21
11567           KFRES=22
11568  
11569         ELSEIF(ISUB.EQ.102) THEN
11570 C...g + g -> h0 (or H0, or A0)
11571           KCC=21
11572           KFRES=KFHIGG
11573  
11574         ELSEIF(ISUB.EQ.103) THEN
11575 C...gamma + gamma -> h0 (or H0, or A0)
11576           KCC=21
11577           KFRES=KFHIGG
11578  
11579         ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11580 C...g + g -> chi_0c or chi_2c.
11581           KCC=21
11582           KFRES=KFPR(ISUB,1)
11583  
11584         ELSEIF(ISUB.EQ.106) THEN
11585 C...g + g -> J/Psi + gamma
11586           MINT(21)=KFPR(ISUB,1)
11587           MINT(22)=KFPR(ISUB,2)
11588           KCC=21
11589  
11590         ELSEIF(ISUB.EQ.107) THEN
11591 C...g + gamma -> J/Psi + g
11592           MINT(21)=KFPR(ISUB,1)
11593           MINT(22)=KFPR(ISUB,2)
11594           KCC=22
11595           IF(MINT(16).EQ.22) KCC=33
11596  
11597         ELSEIF(ISUB.EQ.108) THEN
11598 C...gamma + gamma -> J/Psi + gamma
11599           MINT(21)=KFPR(ISUB,1)
11600           MINT(22)=KFPR(ISUB,2)
11601  
11602         ELSEIF(ISUB.EQ.110) THEN
11603 C...f + fbar -> gamma + h0; th arbitrary
11604           IF(PYR(0).GT.0.5D0) JS=2
11605           MINT(20+JS)=22
11606           MINT(23-JS)=KFHIGG
11607         ENDIF
11608  
11609       ELSEIF(ISUB.LE.120) THEN
11610         IF(ISUB.EQ.111) THEN
11611 C...f + fbar -> g + h0; th arbitrary
11612           IF(PYR(0).GT.0.5D0) JS=2
11613           MINT(20+JS)=21
11614           MINT(23-JS)=KFHIGG
11615           KCC=17+JS
11616  
11617         ELSEIF(ISUB.EQ.112) THEN
11618 C...f + g -> f + h0; th = (p(f) - p(f))**2
11619           IF(MINT(15).EQ.21) JS=2
11620           MINT(23-JS)=KFHIGG
11621           KCC=15+JS
11622           KCS=ISIGN(1,MINT(14+JS))
11623  
11624         ELSEIF(ISUB.EQ.113) THEN
11625 C...g + g -> g + h0; th arbitrary
11626           IF(PYR(0).GT.0.5D0) JS=2
11627           MINT(23-JS)=KFHIGG
11628           KCC=22+JS
11629           KCS=(-1)**INT(1.5D0+PYR(0))
11630  
11631         ELSEIF(ISUB.EQ.114) THEN
11632 C...g + g -> gamma + gamma; th arbitrary
11633           IF(PYR(0).GT.0.5D0) JS=2
11634           MINT(21)=22
11635           MINT(22)=22
11636           KCC=21
11637  
11638         ELSEIF(ISUB.EQ.115) THEN
11639 C...g + g -> g + gamma; th arbitrary
11640           IF(PYR(0).GT.0.5D0) JS=2
11641           MINT(23-JS)=22
11642           KCC=22+JS
11643           KCS=(-1)**INT(1.5D0+PYR(0))
11644  
11645         ELSEIF(ISUB.EQ.116) THEN
11646 C...g + g -> gamma + Z0
11647  
11648         ELSEIF(ISUB.EQ.117) THEN
11649 C...g + g -> Z0 + Z0
11650  
11651         ELSEIF(ISUB.EQ.118) THEN
11652 C...g + g -> W+ + W-
11653         ENDIF
11654  
11655       ELSEIF(ISUB.LE.140) THEN
11656         IF(ISUB.EQ.121) THEN
11657 C...g + g -> Q + Qbar + h0
11658           KCS=(-1)**INT(1.5D0+PYR(0))
11659           MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11660           MINT(22)=-MINT(21)
11661           KCC=11+INT(0.5D0+PYR(0))
11662           KFRES=KFHIGG
11663  
11664         ELSEIF(ISUB.EQ.122) THEN
11665 C...q + qbar -> Q + Qbar + h0
11666           MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11667           MINT(22)=-MINT(21)
11668           KCC=4
11669           KFRES=KFHIGG
11670  
11671         ELSEIF(ISUB.EQ.123) THEN
11672 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11673 C...inner process)
11674           KCC=22
11675           KFRES=KFHIGG
11676  
11677         ELSEIF(ISUB.EQ.124) THEN
11678 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11679 C...inner process)
11680           DO 430 JT=1,2
11681             I=MINT(14+JT)
11682             IA=IABS(I)
11683             IF(IA.LE.10) THEN
11684               RVCKM=VINT(180+I)*PYR(0)
11685               DO 420 J=1,MSTP(1)
11686                 IB=2*J-1+MOD(IA,2)
11687                 IPM=(5-ISIGN(1,I))/2
11688                 IDC=J+MDCY(IA,2)+2
11689                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11690                 MINT(20+JT)=ISIGN(IB,I)
11691                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11692                 IF(RVCKM.LE.0D0) GOTO 430
11693   420         CONTINUE
11694             ELSE
11695               IB=2*((IA+1)/2)-1+MOD(IA,2)
11696               MINT(20+JT)=ISIGN(IB,I)
11697             ENDIF
11698   430     CONTINUE
11699           KCC=22
11700           KFRES=KFHIGG
11701  
11702         ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11703 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11704           IF(MINT(15).EQ.22) JS=2
11705           MINT(23-JS)=21
11706           KCC=24+JS
11707           KCS=ISIGN(1,MINT(14+JS))
11708  
11709         ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11710 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11711           IF(MINT(15).EQ.22) JS=2
11712           KCC=22
11713           KCS=ISIGN(1,MINT(14+JS))
11714  
11715         ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11716 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11717           KCS=(-1)**INT(1.5D0+PYR(0))
11718           MINT(21)=ISIGN(KFLF,KCS)
11719           MINT(22)=-MINT(21)
11720           KCC=27
11721           IF(MINT(16).EQ.21) KCC=28
11722  
11723         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11724 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11725           KCS=(-1)**INT(1.5D0+PYR(0))
11726           MINT(21)=ISIGN(KFLF,KCS)
11727           MINT(22)=-MINT(21)
11728           KCC=21
11729  
11730         ENDIF
11731  
11732       ELSEIF(ISUB.LE.160) THEN
11733         IF(ISUB.EQ.141) THEN
11734 C...f + fbar -> gamma*/Z0/Z'0
11735           KFRES=32
11736  
11737         ELSEIF(ISUB.EQ.142) THEN
11738 C...f + fbar' -> W'+/-
11739           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11740           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11741           KFRES=ISIGN(34,KCH1+KCH2)
11742  
11743         ELSEIF(ISUB.EQ.143) THEN
11744 C...f + fbar' -> H+/-
11745           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11746           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11747           KFRES=ISIGN(37,KCH1+KCH2)
11748  
11749         ELSEIF(ISUB.EQ.144) THEN
11750 C...f + fbar' -> R
11751           KFRES=ISIGN(41,MINT(15)+MINT(16))
11752  
11753         ELSEIF(ISUB.EQ.145) THEN
11754 C...q + l -> LQ (leptoquark)
11755           IF(IABS(MINT(16)).LE.8) JS=2
11756           KFRES=ISIGN(42,MINT(14+JS))
11757           KCC=28+JS
11758           KCS=ISIGN(1,MINT(14+JS))
11759  
11760         ELSEIF(ISUB.EQ.146) THEN
11761 C...e + gamma -> e* (excited lepton)
11762           IF(MINT(15).EQ.22) JS=2
11763           KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11764           KCC=22
11765  
11766         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11767 C...q + g -> q* (excited quark)
11768           IF(MINT(15).EQ.21) JS=2
11769           KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11770           KCC=30+JS
11771           KCS=ISIGN(1,MINT(14+JS))
11772  
11773         ELSEIF(ISUB.EQ.149) THEN
11774 C...g + g -> eta_tc
11775           KFRES=KTECHN+331
11776           KCC=23
11777           KCS=(-1)**INT(1.5D0+PYR(0))
11778         ENDIF
11779  
11780       ELSEIF(ISUB.LE.200) THEN
11781         IF(ISUB.EQ.161) THEN
11782 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11783           IF(MINT(15).EQ.21) JS=2
11784           I=MINT(14+JS)
11785           IA=IABS(I)
11786           MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11787           IB=IA+MOD(IA,2)-MOD(IA+1,2)
11788           MINT(20+JS)=ISIGN(IB,I)
11789           KCC=15+JS
11790           KCS=ISIGN(1,MINT(14+JS))
11791  
11792         ELSEIF(ISUB.EQ.162) THEN
11793 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11794           IF(MINT(15).EQ.21) JS=2
11795           MINT(20+JS)=ISIGN(42,MINT(14+JS))
11796           KFLQL=KFDP(MDCY(42,2),2)
11797           MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11798           KCC=15+JS
11799           KCS=ISIGN(1,MINT(14+JS))
11800  
11801         ELSEIF(ISUB.EQ.163) THEN
11802 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11803           KCS=(-1)**INT(1.5D0+PYR(0))
11804           MINT(21)=ISIGN(42,KCS)
11805           MINT(22)=-MINT(21)
11806           KCC=MINT(2)+10
11807  
11808         ELSEIF(ISUB.EQ.164) THEN
11809 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11810           MINT(21)=ISIGN(42,MINT(15))
11811           MINT(22)=-MINT(21)
11812           KCC=4
11813  
11814         ELSEIF(ISUB.EQ.165) THEN
11815 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11816           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11817           MINT(22)=-MINT(21)
11818  
11819         ELSEIF(ISUB.EQ.166) THEN
11820 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11821           IF(MOD(MINT(15),2).EQ.0) THEN
11822             MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11823             MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11824           ELSE
11825             MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11826             MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11827           ENDIF
11828  
11829         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11830 C...q + q' -> q" + q* (excited quark)
11831           KFQSTR=KFPR(ISUB,2)
11832           KFQEXC=MOD(KFQSTR,KEXCIT)
11833           JS=MINT(2)
11834           MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11835           IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11836      &    MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11837           KCC=22
11838           JS=3-JS
11839  
11840         ELSEIF(ISUB.EQ.169) THEN
11841 C...q + qbar -> e + e* (excited lepton)
11842           KFQSTR=KFPR(ISUB,2)
11843           KFQEXC=MOD(KFQSTR,KEXCIT)
11844           JS=MINT(2)
11845           MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11846           MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11847           JS=3-JS
11848  
11849         ELSEIF(ISUB.EQ.191) THEN
11850 C...f + fbar -> rho_tc0.
11851           KFRES=KTECHN+113
11852  
11853         ELSEIF(ISUB.EQ.192) THEN
11854 C...f + fbar' -> rho_tc+/-
11855           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11856           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11857           KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11858  
11859         ELSEIF(ISUB.EQ.193) THEN
11860 C...f + fbar -> omega_tc0.
11861           KFRES=KTECHN+223
11862  
11863         ELSEIF(ISUB.EQ.194) THEN
11864 C...f + fbar -> f' + fbar' via mixture of s-channel
11865 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11866           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11867           MINT(22)=-MINT(21)
11868  
11869         ELSEIF(ISUB.EQ.195) THEN
11870 C...f + fbar' -> f'' + fbar''' via s-channel
11871 C...rho_tc+ th=(p(f)-p(f'))**2
11872 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11873           IF(MOD(MINT(15),2).EQ.0) THEN
11874             MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11875             MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11876           ELSE
11877             MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11878             MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11879           ENDIF
11880         ENDIF
11881  
11882 CMRENNA++
11883       ELSEIF(ISUB.LE.215) THEN
11884         IF(ISUB.EQ.201) THEN
11885 C...f + fbar -> ~e_L + ~e_Lbar
11886           MINT(21)=ISIGN(KSUSY1+11,KCS)
11887           MINT(22)=-MINT(21)
11888  
11889         ELSEIF(ISUB.EQ.202) THEN
11890 C...f + fbar -> ~e_R + ~e_Rbar
11891           MINT(21)=ISIGN(KSUSY2+11,KCS)
11892           MINT(22)=-MINT(21)
11893  
11894         ELSEIF(ISUB.EQ.203) THEN
11895 C...f + fbar -> ~e_L + ~e_Rbar
11896           IF(MINT(15).LT.0) JS=2
11897           IF(MINT(2).EQ.1) THEN
11898             MINT(20+JS)=KFPR(ISUB,1)
11899             MINT(23-JS)=-KFPR(ISUB,2)
11900           ELSE
11901             MINT(20+JS)=-KFPR(ISUB,1)
11902             MINT(23-JS)=KFPR(ISUB,2)
11903           ENDIF
11904  
11905         ELSEIF(ISUB.EQ.204) THEN
11906 C...f + fbar -> ~mu_L + ~mu_Lbar
11907           MINT(21)=ISIGN(KSUSY1+13,KCS)
11908           MINT(22)=-MINT(21)
11909  
11910         ELSEIF(ISUB.EQ.205) THEN
11911 C...f + fbar -> ~mu_R + ~mu_Rbar
11912           MINT(21)=ISIGN(KSUSY2+13,KCS)
11913           MINT(22)=-MINT(21)
11914  
11915         ELSEIF(ISUB.EQ.206) THEN
11916 C...f + fbar -> ~mu_L + ~mu_Rbar
11917           IF(MINT(15).LT.0) JS=2
11918           IF(MINT(2).EQ.1) THEN
11919             MINT(20+JS)=KFPR(ISUB,1)
11920             MINT(23-JS)=-KFPR(ISUB,2)
11921           ELSE
11922             MINT(20+JS)=-KFPR(ISUB,1)
11923             MINT(23-JS)=KFPR(ISUB,2)
11924           ENDIF
11925  
11926         ELSEIF(ISUB.EQ.207) THEN
11927 C...f + fbar -> ~tau_1 + ~tau_1bar
11928           MINT(21)=ISIGN(KSUSY1+15,KCS)
11929           MINT(22)=-MINT(21)
11930  
11931         ELSEIF(ISUB.EQ.208) THEN
11932 C...f + fbar -> ~tau_2 + ~tau_2bar
11933           MINT(21)=ISIGN(KSUSY2+15,KCS)
11934           MINT(22)=-MINT(21)
11935  
11936         ELSEIF(ISUB.EQ.209) THEN
11937 C...f + fbar -> ~tau_1 + ~tau_2bar
11938           IF(MINT(15).LT.0) JS=2
11939           IF(MINT(2).EQ.1) THEN
11940             MINT(20+JS)=KFPR(ISUB,1)
11941             MINT(23-JS)=-KFPR(ISUB,2)
11942           ELSE
11943             MINT(20+JS)=-KFPR(ISUB,1)
11944             MINT(23-JS)=KFPR(ISUB,2)
11945           ENDIF
11946  
11947         ELSEIF(ISUB.EQ.210) THEN
11948 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11949           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11950           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11951           MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11952           MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11953  
11954         ELSEIF(ISUB.EQ.211) THEN
11955 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11956           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11957           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11958           MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11959           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11960  
11961         ELSEIF(ISUB.EQ.212) THEN
11962 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11963           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11964           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11965           MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11966           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11967  
11968         ELSEIF(ISUB.EQ.213) THEN
11969 C...f + fbar -> ~nul + ~nulbar
11970           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11971           MINT(22)=-MINT(21)
11972  
11973         ELSEIF(ISUB.EQ.214) THEN
11974 C...f + fbar -> ~nutau + ~nutaubar
11975           MINT(21)=ISIGN(KSUSY1+16,KCS)
11976           MINT(22)=-MINT(21)
11977         ENDIF
11978  
11979       ELSEIF(ISUB.LE.225) THEN
11980         IF(ISUB.EQ.216) THEN
11981 C...f + fbar -> ~chi01 + ~chi01
11982           MINT(21)=KSUSY1+22
11983           MINT(22)=KSUSY1+22
11984  
11985         ELSEIF(ISUB.EQ.217) THEN
11986 C...f + fbar -> ~chi02 + ~chi02
11987           MINT(21)=KSUSY1+23
11988           MINT(22)=KSUSY1+23
11989  
11990         ELSEIF(ISUB.EQ.218 ) THEN
11991 C...f + fbar -> ~chi03 + ~chi03
11992           MINT(21)=KSUSY1+25
11993           MINT(22)=KSUSY1+25
11994  
11995         ELSEIF(ISUB.EQ.219 ) THEN
11996 C...f + fbar -> ~chi04 + ~chi04
11997           MINT(21)=KSUSY1+35
11998           MINT(22)=KSUSY1+35
11999  
12000         ELSEIF(ISUB.EQ.220 ) THEN
12001 C...f + fbar -> ~chi01 + ~chi02
12002           IF(MINT(15).LT.0) JS=2
12003 C          IF(PYR(0).GT.0.5D0) JS=2
12004           MINT(20+JS)=KSUSY1+22
12005           MINT(23-JS)=KSUSY1+23
12006  
12007         ELSEIF(ISUB.EQ.221 ) THEN
12008 C...f + fbar -> ~chi01 + ~chi03
12009           IF(MINT(15).LT.0) JS=2
12010 C          IF(PYR(0).GT.0.5D0) JS=2
12011           MINT(20+JS)=KSUSY1+22
12012           MINT(23-JS)=KSUSY1+25
12013  
12014         ELSEIF(ISUB.EQ.222) THEN
12015 C...f + fbar -> ~chi01 + ~chi04
12016           IF(MINT(15).LT.0) JS=2
12017 C          IF(PYR(0).GT.0.5D0) JS=2
12018           MINT(20+JS)=KSUSY1+22
12019           MINT(23-JS)=KSUSY1+35
12020  
12021         ELSEIF(ISUB.EQ.223) THEN
12022 C...f + fbar -> ~chi02 + ~chi03
12023           IF(MINT(15).LT.0) JS=2
12024 C          IF(PYR(0).GT.0.5D0) JS=2
12025           MINT(20+JS)=KSUSY1+23
12026           MINT(23-JS)=KSUSY1+25
12027  
12028         ELSEIF(ISUB.EQ.224) THEN
12029 C...f + fbar -> ~chi02 + ~chi04
12030           IF(MINT(15).LT.0) JS=2
12031 C          IF(PYR(0).GT.0.5D0) JS=2
12032           MINT(20+JS)=KSUSY1+23
12033           MINT(23-JS)=KSUSY1+35
12034  
12035         ELSEIF(ISUB.EQ.225) THEN
12036 C...f + fbar -> ~chi03 + ~chi04
12037           IF(MINT(15).LT.0) JS=2
12038 C          IF(PYR(0).GT.0.5D0) JS=2
12039           MINT(20+JS)=KSUSY1+25
12040           MINT(23-JS)=KSUSY1+35
12041         ENDIF
12042  
12043       ELSEIF(ISUB.LE.236) THEN
12044         IF(ISUB.EQ.226) THEN
12045 C...f + fbar -> ~chi+-1 + ~chi-+1
12046 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
12047           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12048           MINT(21)=ISIGN(KSUSY1+24,KCH1)
12049           MINT(22)=-MINT(21)
12050  
12051         ELSEIF(ISUB.EQ.227) THEN
12052 C...f + fbar -> ~chi+-2 + ~chi-+2
12053           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12054           MINT(21)=ISIGN(KSUSY1+37,KCH1)
12055           MINT(22)=-MINT(21)
12056  
12057         ELSEIF(ISUB.EQ.228) THEN
12058 C...f + fbar -> ~chi+-1 + ~chi-+2
12059 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
12060 C...js=1 if pyr<.5, js=2 if pyr>.5
12061 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
12062 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
12063 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
12064 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
12065           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12066           KCH2=INT(1-KCH1)/2
12067           IF(MINT(2).EQ.1) THEN
12068             MINT(21)= ISIGN(KSUSY1+24,KCH1)
12069             MINT(22)= -ISIGN(KSUSY1+37,KCH1)
12070 c            IF(KCH2.EQ.0) JS=2
12071           ELSE
12072             MINT(21)= ISIGN(KSUSY1+37,KCH1)
12073             MINT(22)= -ISIGN(KSUSY1+24,KCH1)
12074             JS=2
12075 c            IF(KCH2.EQ.1) JS=2
12076           ENDIF
12077  
12078         ELSEIF(ISUB.EQ.229) THEN
12079 C...q + qbar' -> ~chi01 + ~chi+-1
12080 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
12081           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12082           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12083 C...CHECK THIS
12084           IF(MOD(MINT(15),2).EQ.0) JS=2
12085           MINT(20+JS)=KSUSY1+22
12086           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12087  
12088         ELSEIF(ISUB.EQ.230) THEN
12089 C...q + qbar' -> ~chi02 + ~chi+-1
12090           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12091           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12092           IF(MOD(MINT(15),2).EQ.0) JS=2
12093           MINT(20+JS)=KSUSY1+23
12094           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12095  
12096         ELSEIF(ISUB.EQ.231) THEN
12097 C...q + qbar' -> ~chi03 + ~chi+-1
12098           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12099           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12100           IF(MOD(MINT(15),2).EQ.0) JS=2
12101           MINT(20+JS)=KSUSY1+25
12102           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12103  
12104         ELSEIF(ISUB.EQ.232) THEN
12105 C...q + qbar' -> ~chi04 + ~chi+-1
12106           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12107           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12108           IF(MOD(MINT(15),2).EQ.0) JS=2
12109           MINT(20+JS)=KSUSY1+35
12110           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12111  
12112         ELSEIF(ISUB.EQ.233) THEN
12113 C...q + qbar' -> ~chi01 + ~chi+-2
12114           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12115           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12116           IF(MOD(MINT(15),2).EQ.0) JS=2
12117           MINT(20+JS)=KSUSY1+22
12118           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12119  
12120         ELSEIF(ISUB.EQ.234) THEN
12121 C...q + qbar' -> ~chi02 + ~chi+-2
12122           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12123           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12124           IF(MOD(MINT(15),2).EQ.0) JS=2
12125           MINT(20+JS)=KSUSY1+23
12126           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12127  
12128         ELSEIF(ISUB.EQ.235) THEN
12129 C...q + qbar' -> ~chi03 + ~chi+-2
12130           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12131           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12132           IF(MOD(MINT(15),2).EQ.0) JS=2
12133           MINT(20+JS)=KSUSY1+25
12134           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12135  
12136         ELSEIF(ISUB.EQ.236) THEN
12137 C...q + qbar' -> ~chi04 + ~chi+-2
12138           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12139           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12140           IF(MOD(MINT(15),2).EQ.0) JS=2
12141           MINT(20+JS)=KSUSY1+35
12142           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12143         ENDIF
12144  
12145       ELSEIF(ISUB.LE.245) THEN
12146         IF(ISUB.EQ.237) THEN
12147 C...q + qbar -> ~chi01 + ~g
12148 C...th arbitrary
12149           IF(PYR(0).GT.0.5D0) JS=2
12150           MINT(20+JS)=KSUSY1+21
12151           MINT(23-JS)=KSUSY1+22
12152           KCC=17+JS
12153  
12154         ELSEIF(ISUB.EQ.238) THEN
12155 C...q + qbar -> ~chi02 + ~g
12156 C...th arbitrary
12157           IF(PYR(0).GT.0.5D0) JS=2
12158           MINT(20+JS)=KSUSY1+21
12159           MINT(23-JS)=KSUSY1+23
12160           KCC=17+JS
12161  
12162         ELSEIF(ISUB.EQ.239) THEN
12163 C...q + qbar -> ~chi03 + ~g
12164 C...th arbitrary
12165           IF(PYR(0).GT.0.5D0) JS=2
12166           MINT(20+JS)=KSUSY1+21
12167           MINT(23-JS)=KSUSY1+25
12168           KCC=17+JS
12169  
12170         ELSEIF(ISUB.EQ.240) THEN
12171 C...q + qbar -> ~chi04 + ~g
12172 C...th arbitrary
12173           IF(PYR(0).GT.0.5D0) JS=2
12174           MINT(20+JS)=KSUSY1+21
12175           MINT(23-JS)=KSUSY1+35
12176           KCC=17+JS
12177  
12178         ELSEIF(ISUB.EQ.241) THEN
12179 C...q + qbar' -> ~chi+-1 + ~g
12180 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12181 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12182 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12183 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12184 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12185           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12186           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12187           JS=1
12188           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12189           MINT(20+JS)=KSUSY1+21
12190           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12191           KCC=17+JS
12192  
12193         ELSEIF(ISUB.EQ.242) THEN
12194 C...q + qbar' -> ~chi+-2 + ~g
12195 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12196 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12197 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12198 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12199 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12200           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12201           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12202           JS=1
12203           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12204           MINT(20+JS)=KSUSY1+21
12205           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12206           KCC=17+JS
12207  
12208         ELSEIF(ISUB.EQ.243) THEN
12209 C...q + qbar -> ~g + ~g ; th arbitrary
12210           MINT(21)=KSUSY1+21
12211           MINT(22)=KSUSY1+21
12212           KCC=MINT(2)+4
12213  
12214         ELSEIF(ISUB.EQ.244) THEN
12215 C...g + g -> ~g + ~g ; th arbitrary
12216           KCC=MINT(2)+12
12217           KCS=(-1)**INT(1.5D0+PYR(0))
12218           MINT(21)=KSUSY1+21
12219           MINT(22)=KSUSY1+21
12220         ENDIF
12221  
12222       ELSEIF(ISUB.LE.260) THEN
12223         IF(ISUB.EQ.246) THEN
12224 C...qj + g -> ~qj_L + ~chi01
12225           IF(MINT(15).EQ.21) JS=2
12226           I=MINT(14+JS)
12227           IA=IABS(I)
12228           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12229           MINT(23-JS)=KSUSY1+22
12230           KCC=15+JS
12231           KCS=ISIGN(1,MINT(14+JS))
12232  
12233         ELSEIF(ISUB.EQ.247) THEN
12234 C...qj + g -> ~qj_R + ~chi01
12235           IF(MINT(15).EQ.21) JS=2
12236           I=MINT(14+JS)
12237           IA=IABS(I)
12238           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12239           MINT(23-JS)=KSUSY1+22
12240           KCC=15+JS
12241           KCS=ISIGN(1,MINT(14+JS))
12242  
12243         ELSEIF(ISUB.EQ.248) THEN
12244 C...qj + g -> ~qj_L + ~chi02
12245           IF(MINT(15).EQ.21) JS=2
12246           I=MINT(14+JS)
12247           IA=IABS(I)
12248           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12249           MINT(23-JS)=KSUSY1+23
12250           KCC=15+JS
12251           KCS=ISIGN(1,MINT(14+JS))
12252  
12253         ELSEIF(ISUB.EQ.249) THEN
12254 C...qj + g -> ~qj_R + ~chi02
12255           IF(MINT(15).EQ.21) JS=2
12256           I=MINT(14+JS)
12257           IA=IABS(I)
12258           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12259           MINT(23-JS)=KSUSY1+23
12260           KCC=15+JS
12261           KCS=ISIGN(1,MINT(14+JS))
12262  
12263         ELSEIF(ISUB.EQ.250) THEN
12264 C...qj + g -> ~qj_L + ~chi03
12265           IF(MINT(15).EQ.21) JS=2
12266           I=MINT(14+JS)
12267           IA=IABS(I)
12268           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12269           MINT(23-JS)=KSUSY1+25
12270           KCC=15+JS
12271           KCS=ISIGN(1,MINT(14+JS))
12272  
12273         ELSEIF(ISUB.EQ.251) THEN
12274 C...qj + g -> ~qj_R + ~chi03
12275           IF(MINT(15).EQ.21) JS=2
12276           I=MINT(14+JS)
12277           IA=IABS(I)
12278           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12279           MINT(23-JS)=KSUSY1+25
12280           KCC=15+JS
12281           KCS=ISIGN(1,MINT(14+JS))
12282  
12283         ELSEIF(ISUB.EQ.252) THEN
12284 C...qj + g -> ~qj_L + ~chi04
12285           IF(MINT(15).EQ.21) JS=2
12286           I=MINT(14+JS)
12287           IA=IABS(I)
12288           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12289           MINT(23-JS)=KSUSY1+35
12290           KCC=15+JS
12291           KCS=ISIGN(1,MINT(14+JS))
12292  
12293         ELSEIF(ISUB.EQ.253) THEN
12294 C...qj + g -> ~qj_R + ~chi04
12295           IF(MINT(15).EQ.21) JS=2
12296           I=MINT(14+JS)
12297           IA=IABS(I)
12298           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12299           MINT(23-JS)=KSUSY1+35
12300           KCC=15+JS
12301           KCS=ISIGN(1,MINT(14+JS))
12302  
12303         ELSEIF(ISUB.EQ.254) THEN
12304 C...qj + g -> ~qk_L + ~chi+-1
12305           IF(MINT(15).EQ.21) JS=2
12306           I=MINT(14+JS)
12307           IA=IABS(I)
12308           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12309           IB=-IA+INT((IA+1)/2)*4-1
12310           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12311           KCC=15+JS
12312           KCS=ISIGN(1,MINT(14+JS))
12313  
12314         ELSEIF(ISUB.EQ.255) THEN
12315 C...qj + g -> ~qk_L + ~chi+-1
12316           IF(MINT(15).EQ.21) JS=2
12317           I=MINT(14+JS)
12318           IA=IABS(I)
12319           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12320           IB=-IA+INT((IA+1)/2)*4-1
12321           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12322           KCC=15+JS
12323           KCS=ISIGN(1,MINT(14+JS))
12324  
12325         ELSEIF(ISUB.EQ.256) THEN
12326 C...qj + g -> ~qk_L + ~chi+-2
12327           IF(MINT(15).EQ.21) JS=2
12328           I=MINT(14+JS)
12329           IA=IABS(I)
12330           IB=-IA+INT((IA+1)/2)*4-1
12331           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12332           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12333           KCC=15+JS
12334           KCS=ISIGN(1,MINT(14+JS))
12335  
12336         ELSEIF(ISUB.EQ.257) THEN
12337 C...qj + g -> ~qk_R + ~chi+-2
12338           IF(MINT(15).EQ.21) JS=2
12339           I=MINT(14+JS)
12340           IA=IABS(I)
12341           IB=-IA+INT((IA+1)/2)*4-1
12342           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12343           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12344           KCC=15+JS
12345           KCS=ISIGN(1,MINT(14+JS))
12346  
12347         ELSEIF(ISUB.EQ.258) THEN
12348 C...qj + g -> ~qj_L + ~g
12349           IF(MINT(15).EQ.21) JS=2
12350           I=MINT(14+JS)
12351           IA=IABS(I)
12352           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12353           MINT(23-JS)=KSUSY1+21
12354           KCC=MINT(2)+6
12355           IF(JS.EQ.2) KCC=KCC+2
12356           KCS=ISIGN(1,I)
12357  
12358         ELSEIF(ISUB.EQ.259) THEN
12359 C...qj + g -> ~qj_R + ~g
12360           IF(MINT(15).EQ.21) JS=2
12361           I=MINT(14+JS)
12362           IA=IABS(I)
12363           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12364           MINT(23-JS)=KSUSY1+21
12365           KCC=MINT(2)+6
12366           IF(JS.EQ.2) KCC=KCC+2
12367           KCS=ISIGN(1,I)
12368         ENDIF
12369  
12370       ELSEIF(ISUB.LE.270) THEN
12371         IF(ISUB.EQ.261) THEN
12372 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12373           ISGN=1
12374           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12375           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12376           MINT(22)=-MINT(21)
12377 C...Correct color combination
12378           IF(MINT(43).EQ.4) KCC=4
12379  
12380         ELSEIF(ISUB.EQ.262) THEN
12381 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12382           ISGN=1
12383           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12384           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12385           MINT(22)=-MINT(21)
12386 C...Correct color combination
12387           IF(MINT(43).EQ.4) KCC=4
12388  
12389         ELSEIF(ISUB.EQ.263) THEN
12390 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12391           IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12392      &    (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12393             MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12394             MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12395           ELSE
12396             JS=2
12397             MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12398             MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12399           ENDIF
12400 C...Correct color combination
12401           IF(MINT(43).EQ.4) KCC=4
12402  
12403         ELSEIF(ISUB.EQ.264) THEN
12404 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12405           KCS=(-1)**INT(1.5D0+PYR(0))
12406           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12407           MINT(22)=-MINT(21)
12408           KCC=MINT(2)+10
12409  
12410         ELSEIF(ISUB.EQ.265) THEN
12411 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12412           KCS=(-1)**INT(1.5D0+PYR(0))
12413           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12414           MINT(22)=-MINT(21)
12415           KCC=MINT(2)+10
12416         ENDIF
12417  
12418       ELSEIF(ISUB.LE.301) THEN
12419         IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12420 C...qi + qj -> ~qi_L + ~qj_L
12421           KCC=MINT(2)
12422           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12423           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12424           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12425  
12426         ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12427 C...qi + qj -> ~qi_R + ~qj_R
12428           KCC=MINT(2)
12429           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12430           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12431           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12432  
12433         ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12434 C...qi + qj -> ~qi_L + ~qj_R
12435           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12436           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12437           KCC=MINT(2)
12438           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12439  
12440         ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12441 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12442           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12443           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12444           KCC=MINT(2)
12445           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12446  
12447         ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12448 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12449           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12450           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12451           KCC=MINT(2)
12452           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12453  
12454         ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12455 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12456           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12457           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12458           KCC=MINT(2)
12459           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12460  
12461         ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12462 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12463           ISGN=1
12464           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12465           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12466           MINT(22)=-MINT(21)
12467           IF(MINT(43).EQ.4) KCC=4
12468  
12469         ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12470 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12471           ISGN=1
12472           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12473           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12474           MINT(22)=-MINT(21)
12475           IF(MINT(43).EQ.4) KCC=4
12476  
12477         ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12478 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12479 C...pure LL + RR
12480           KCS=(-1)**INT(1.5D0+PYR(0))
12481           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12482           MINT(22)=-MINT(21)
12483           KCC=MINT(2)+10
12484  
12485         ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12486 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12487           KCS=(-1)**INT(1.5D0+PYR(0))
12488           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12489           MINT(22)=-MINT(21)
12490           KCC=MINT(2)+10
12491  
12492         ELSEIF(ISUB.EQ.294) THEN
12493 C...qj + g -> ~qj_L + ~g
12494           IF(MINT(15).EQ.21) JS=2
12495           I=MINT(14+JS)
12496           IA=IABS(I)
12497           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12498           MINT(23-JS)=KSUSY1+21
12499           KCC=MINT(2)+6
12500           IF(JS.EQ.2) KCC=KCC+2
12501           KCS=ISIGN(1,I)
12502  
12503         ELSEIF(ISUB.EQ.295) THEN
12504 C...qj + g -> ~qj_R + ~g
12505           IF(MINT(15).EQ.21) JS=2
12506           I=MINT(14+JS)
12507           IA=IABS(I)
12508           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12509           MINT(23-JS)=KSUSY1+21
12510           KCC=MINT(2)+6
12511           IF(JS.EQ.2) KCC=KCC+2
12512           KCS=ISIGN(1,I)
12513  
12514         ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12515 C...q + qbar' -> H+ + H0
12516           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12517           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12518           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12519           MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12520           MINT(23-JS)=KFPR(ISUB,2)
12521         ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12522 C...f + fbar -> A0 + H0; th arbitrary
12523           IF(PYR(0).GT.0.5D0) JS=2
12524           MINT(20+JS)=KFPR(ISUB,1)
12525           MINT(23-JS)=KFPR(ISUB,2)
12526         ELSEIF(ISUB.EQ.301) THEN
12527 C...f + fbar -> H+ H-
12528           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12529           MINT(22)=-MINT(21)
12530         ENDIF
12531 CMRENNA--
12532       ELSEIF(ISUB.LE.330) THEN
12533         IF(ISUB.EQ.311)THEN
12534 C...g + g -> g* + g* (UED)
12535           KCC=MINT(2)+12
12536           KCS=(-1)**INT(1.5D0+PYR(0))
12537           MUED(1)=472
12538           MUED(2)=472
12539           MINT(21)=IUEDEQ(472)
12540           MINT(22)=IUEDEQ(472)
12541         ELSEIF(ISUB.EQ.312)THEN
12542 C...q + g -> q*_D + g*, q*_S + g*
12543 C...The two channels have the same cross section
12544           KKFLMI=450
12545           IF(PYR(0).GT.0.5)KKFLMI=456
12546           IF(MINT(15).EQ.21) JS=2
12547           KCC=MINT(2)+6
12548           IF(MINT(15).EQ.21)KCC=KCC+2
12549           IF(MINT(15).NE.21)THEN
12550             KCS=ISIGN(1,MINT(15))
12551             MUED(2)=472
12552             MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12553             MINT(22)=IUEDEQ(472)
12554             MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12555           ENDIF
12556           IF(MINT(16).NE.21)THEN
12557             KCS=ISIGN(1,MINT(16))
12558             MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12559             MUED(1)=472
12560             MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12561             MINT(21)=IUEDEQ(472)
12562           ENDIF
12563         ELSEIF(ISUB.EQ.313)THEN
12564 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12565 C...The two channels have the same cross section
12566           KKFLMI=450
12567           IF(PYR(0).GT.0.5)KKFLMI=456
12568           KCC=MINT(2)         
12569           IF(MINT(15).EQ.MINT(16))THEN
12570             MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12571             MUED(2)=MINT(21)
12572             MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12573             MINT(22)=MINT(21)
12574           ELSE
12575             MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12576             MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12577             MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12578             MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12579           ENDIF
12580           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2        
12581         ELSEIF(ISUB.EQ.314)THEN
12582 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12583 C...The two channels have the same cross section
12584           KKFLMI=450
12585           IF(PYR(0).GT.0.5)KKFLMI=456
12586           KCS=(-1)**INT(1.5D0+PYR(0))    
12587           XFLAOUT=PYR(0)
12588           IF(XFLAOUT.LE.0.2)THEN
12589             MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12590             MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12591           ELSEIF(XFLAOUT.LE.0.4)THEN
12592             MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12593             MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12594           ELSEIF(XFLAOUT.LE.0.6)THEN
12595             MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12596             MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12597           ELSEIF(XFLAOUT.LE.0.8)THEN
12598             MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12599             MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12600           ELSE
12601             MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12602             MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12603           ENDIF
12604           MINT(22)=-MINT(21)
12605           MUED(2)=-MUED(1)
12606           KCC=MINT(2)+10
12607         ELSEIF(ISUB.EQ.315)THEN
12608 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12609 C...The two channels have the same cross section
12610           KKFLMI=450
12611           IF(PYR(0).GT.0.5)KKFLMI=456
12612           MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12613           MUED(2)=-MINT(21)
12614           MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12615           MINT(22)=-MINT(21)
12616           KCC=4
12617         ELSEIF(ISUB.EQ.316)THEN
12618 C...q + qbar'    -> q*_D + q*_S_bar'
12619           MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12620           MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12621           MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12622           MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12623           KCC=MINT(2)+2
12624         ELSEIF(ISUB.EQ.317)THEN
12625 C...q + qbar'    -> q*_D + q*_D_bar', q*_S + q*_S_bar
12626 C...The two channels have the same cross section
12627           KKFLMI=450
12628           IF(PYR(0).GT.0.5)KKFLMI=456      
12629           MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12630           MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12631           MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12632           MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12633           KCC=MINT(2)+2
12634         ELSEIF(ISUB.EQ.318)THEN
12635 C...q + q'    -> q*_D + q*_S'     
12636           KCC=MINT(2)         
12637           MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12638           MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))               
12639           MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12640           MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12641         ELSEIF(ISUB.EQ.319)THEN
12642 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12643 C...The two channels have the same cross section
12644           KKFLMI=450
12645           IF(PYR(0).GT.0.5)KKFLMI=456
12646           XFLAOUT=PYR(0)
12647           IIFLAV=0
12648 C...N.B. NFLAVOURS=IUED(3)
12649 C   DO I=1,NFLAVOURS
12650           DO 433 I=1,IUED(3)
12651             IF(I.NE.IABS(MINT(15)))THEN
12652               IIFLAV=IIFLAV+1
12653               IOKFLA(IIFLAV)=I
12654             ENDIF
12655  433      CONTINUE
12656           FLASTEP=1./(IUED(3)-1)
12657           DO I=1,IUED(3)-1
12658             FLAVV=FLASTEP*I
12659             IF(XFLAOUT.LE.FLAVV)THEN                  
12660               MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12661               MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12662               GOTO 435
12663             ENDIF
12664           ENDDO
12665  435      CONTINUE
12666           IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12667             WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12668             CALL PYSTOP(5000000)
12669           ENDIF
12670           MINT(22)=-MINT(21)
12671           KCC=4
12672         ENDIF
12673          
12674       ELSEIF(ISUB.LE.360) THEN
12675  
12676         IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12677 C...l + l -> H_L++/--, H_R++/--
12678           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12679           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12680           KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12681  
12682         ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12683 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12684           IF(MINT(15).EQ.22) JS=2
12685           MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12686           MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12687           KCC=22
12688  
12689         ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12690 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12691           MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12692           MINT(22)=-MINT(21)
12693  
12694         ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12695 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12696 C...as inner process).
12697           DO 450 JT=1,2
12698             I=MINT(14+JT)
12699             IA=IABS(I)
12700             IF(IA.LE.10) THEN
12701               RVCKM=VINT(180+I)*PYR(0)
12702               DO 440 J=1,MSTP(1)
12703                 IB=2*J-1+MOD(IA,2)
12704                 IPM=(5-ISIGN(1,I))/2
12705                 IDC=J+MDCY(IA,2)+2
12706                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12707                 MINT(20+JT)=ISIGN(IB,I)
12708                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12709                 IF(RVCKM.LE.0D0) GOTO 450
12710   440         CONTINUE
12711             ELSE
12712               IB=2*((IA+1)/2)-1+MOD(IA,2)
12713               MINT(20+JT)=ISIGN(IB,I)
12714             ENDIF
12715   450     CONTINUE
12716           KCC=22
12717           KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12718           IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12719  
12720         ELSEIF(ISUB.EQ.353) THEN
12721 C...f + fbar -> Z_R0
12722           KFRES=KFPR(ISUB,1)
12723  
12724         ELSEIF(ISUB.EQ.354) THEN
12725 C...f + fbar' -> W+/-
12726           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12727           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12728           KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12729  
12730         ENDIF
12731  
12732       ELSEIF(ISUB.LE.380) THEN
12733  
12734         IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12735 C...f + fbar -> charged+ charged- technicolor
12736           KSW=(-1)**INT(1.5D0+PYR(0))
12737           MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12738           MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12739  
12740         ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12741 C...f + fbar -> neutral neutral technicolor
12742           MINT(21)=KFPR(ISUB,1)
12743           MINT(22)=KFPR(ISUB,2)
12744  
12745         ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12746 C...f + fbar' -> neutral charged technicolor
12747           IN=1
12748           IC=2
12749           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12750           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12751           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12752           MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12753           MINT(20+JS)=KFPR(ISUB,IN)
12754  
12755         ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12756 C...f + fbar' -> charged neutral technicolor
12757           IN=2
12758           IC=1
12759           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12760           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12761           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12762           MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12763           MINT(23-JS)=KFPR(ISUB,IN)
12764         ENDIF
12765  
12766       ELSEIF(ISUB.LE.400) THEN
12767         IF(ISUB.EQ.381) THEN
12768 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12769           KCC=MINT(2)
12770           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12771  
12772         ELSEIF(ISUB.EQ.382) THEN
12773 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12774           MINT(21)=ISIGN(KFLF,MINT(15))
12775           MINT(22)=-MINT(21)
12776           KCC=4
12777  
12778         ELSEIF(ISUB.EQ.383) THEN
12779 C...f + fbar -> g + g; th arbitrary, TC extensions
12780           MINT(21)=21
12781           MINT(22)=21
12782           KCC=MINT(2)+4
12783  
12784         ELSEIF(ISUB.EQ.384) THEN
12785 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12786           IF(MINT(15).EQ.21) JS=2
12787           KCC=MINT(2)+6
12788           IF(MINT(15).EQ.21) KCC=KCC+2
12789           IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12790           IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12791  
12792         ELSEIF(ISUB.EQ.385) THEN
12793 C...g + g -> f + fbar; th arbitrary, TC extensions
12794           KCS=(-1)**INT(1.5D0+PYR(0))
12795           MINT(21)=ISIGN(KFLF,KCS)
12796           MINT(22)=-MINT(21)
12797           KCC=MINT(2)+10
12798  
12799         ELSEIF(ISUB.EQ.386) THEN
12800 C...g + g -> g + g; th arbitrary, TC extensions
12801           KCC=MINT(2)+12
12802           KCS=(-1)**INT(1.5D0+PYR(0))
12803  
12804         ELSEIF(ISUB.EQ.387) THEN
12805 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12806           MINT(21)=ISIGN(MINT(55),MINT(15))
12807           MINT(22)=-MINT(21)
12808           KCC=4
12809  
12810         ELSEIF(ISUB.EQ.388) THEN
12811 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12812           KCS=(-1)**INT(1.5D0+PYR(0))
12813           MINT(21)=ISIGN(MINT(55),KCS)
12814           MINT(22)=-MINT(21)
12815           KCC=MINT(2)+10
12816  
12817         ELSEIF(ISUB.EQ.391) THEN
12818 C...f + fbar -> G*.
12819           KFRES=KFPR(ISUB,1)
12820  
12821         ELSEIF(ISUB.EQ.392) THEN
12822 C...g + g -> G*.
12823           KCC=21
12824           KFRES=KFPR(ISUB,1)
12825  
12826         ELSEIF(ISUB.EQ.393) THEN
12827 C...q + qbar -> g + G*;  th arbitrary.
12828           IF(PYR(0).GT.0.5D0) JS=2
12829           MINT(20+JS)=KFPR(ISUB,1)
12830           MINT(23-JS)=KFPR(ISUB,2)
12831           KCC=17+JS
12832  
12833         ELSEIF(ISUB.EQ.394) THEN
12834 C...q + g -> q + G*;  th = (p(f) - p(f))**2
12835           IF(MINT(15).EQ.21) JS=2
12836           MINT(23-JS)=KFPR(ISUB,2)
12837           KCC=15+JS
12838           KCS=ISIGN(1,MINT(14+JS))
12839  
12840         ELSEIF(ISUB.EQ.395) THEN
12841 C...g + g -> G* + g;  th arbitrary.
12842           IF(PYR(0).GT.0.5D0) JS=2
12843           MINT(23-JS)=KFPR(ISUB,2)
12844           KCC=22+JS
12845         ENDIF
12846  
12847       ELSEIF(ISUB.LE.420) THEN
12848         IF(ISUB.EQ.401) THEN
12849 C...g + g -> t + b + H+/-
12850           KCS=(-1)**INT(1.5D0+PYR(0))
12851           MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12852           MINT(22)=ISIGN(5,-KCS)
12853           KCC=11+INT(0.5D0+PYR(0))
12854           KFRES=ISIGN(KFHIGG,-KCS)
12855  
12856         ELSEIF(ISUB.EQ.402) THEN
12857 C...q + qbar -> t + b + H+/-
12858           KFL=(-1)**INT(1.5D0+PYR(0))
12859           MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12860           MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12861           KCC=4
12862           KFRES=ISIGN(KFHIGG,-KFL*KCS)
12863         ENDIF
12864  
12865 C...QUARKONIA+++
12866 C...Additional code by Stefan Wolf
12867       ELSEIF(ISUB.LE.430) THEN
12868         IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12869 C...g + g -> QQ~[n] + g
12870 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12871 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12872 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12873 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12874 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12875 C...[g + g -> g + g; th arbitrary]
12876           MINT(21)=KFPR(ISUBSV,1)
12877           MINT(22)=KFPR(ISUBSV,2)
12878           IF(ISUB.EQ.421) THEN
12879              KCC=24
12880              KCS=(-1)**INT(1.5D0+PYR(0))
12881           ELSE
12882              KCC=MINT(2)+12
12883              KCS=(-1)**INT(1.5D0+PYR(0))
12884           ENDIF
12885  
12886         ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12887 C...q + g -> q + QQ~[n]
12888 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12889 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12890 C...KCC copied from ISUB.EQ.28
12891 C...[f + g -> f + g;  th = (p(f)-p(f))**2; (q + g -> q + g  only)]
12892           IF(MINT(15).EQ.21) JS=2
12893           MINT(23-JS)=KFPR(ISUBSV,2)
12894           KCC=MINT(2)+6
12895           IF(MINT(15).EQ.21) KCC=KCC+2
12896           IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12897           IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12898  
12899         ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12900 C...q + q~ -> g + QQ~[n]
12901 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12902 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12903 C...KCC copied from ISUB.EQ.13
12904 C...[f + fbar -> g + g;  th arbitrary; (q + qbar -> g + g  only)]
12905           IF(PYR(0).GT.0.5) JS=2
12906           MINT(20+JS)=21
12907           MINT(23-JS)=KFPR(ISUBSV,2)
12908           KCC=MINT(2)+4
12909         ENDIF
12910  
12911       ELSEIF(ISUB.LE.440) THEN
12912         IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12913 C...g + g -> QQ~[n] + g
12914 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12915 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12916 C...KCC and KCS copied from ISUB.EQ.86-89
12917 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12918           MINT(21)=KFPR(ISUBSV,1)
12919           MINT(22)=KFPR(ISUBSV,2)
12920           KCC=24
12921           KCS=(-1)**INT(1.5D0+PYR(0))
12922  
12923         ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12924 C...q + g -> q + QQ~[n]
12925 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12926 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12927 C...KCC and KCS copied from ISUB.EQ.112
12928 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12929           IF(MINT(15).EQ.21) JS=2
12930           MINT(23-JS)=KFPR(ISUBSV,2)
12931           KCC=15+JS
12932           KCS=ISIGN(1,MINT(14+JS))
12933  
12934         ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12935 C...q + q~ -> g + QQ~[n]
12936 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12937 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12938 C...KCC copied from ISUB.EQ.111
12939 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12940           IF(PYR(0).GT.0.5) JS=2
12941           MINT(20+JS)=21
12942           MINT(23-JS)=KFPR(ISUBSV,2)
12943           KCC=17+JS
12944 C...QUARKONIA---
12945         ENDIF
12946       ELSEIF(ISUB.LE.500) THEN
12947         IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
12948           KFRES=9900001
12949           KCRES=PYCOMP(KFRES)
12950           MCOL=KCHG(KCRES,2)
12951           MCHG=KCHG(KCRES,1)
12952           IF(KCRES.EQ.0) 
12953      $      CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
12954           IDCY=MDCY(KCRES,2)
12955           IF(IDCY.EQ.0)
12956      $      CALL PYERRM(21,"No decays for resonance in Generic 2->2")
12957           KCI1=PYCOMP(MINT(15))
12958           KCI2=PYCOMP(MINT(16))
12959           ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
12960           ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
12961           KFF1=KFPR(ISUB,1)
12962           KFF2=KFPR(ISUB,2)
12963           KCF1=PYCOMP(KFF1)
12964           KCF2=PYCOMP(KFF2)
12965           JCOL1=SIGN(KCHG(KCF1,2),KFF1)
12966           IF(JCOL1.EQ.-2) JCOL1=2
12967           JCOL2=SIGN(KCHG(KCF2,2),KFF2)
12968           IF(JCOL2.EQ.-2) JCOL2=2
12969           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12970           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12971           KCHW=KCH1+KCH2
12972           KREL=1
12973           IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
12974           IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
12975           IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
12976           IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
12977           IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
12978           IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
12979      $      (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
12980             IF(PYR(0).GT.0.5D0) JS=2
12981             MINT(20+JS)=KFF1
12982             MINT(23-JS)=KFF2
12983             IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
12984 
12985             ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
12986               KCC=17+JS
12987               MINT(20+JS)=KFF2
12988               MINT(23-JS)=KFF1
12989             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
12990               KCC=17+JS
12991               MINT(20+JS)=KFF1
12992               MINT(23-JS)=KFF2
12993             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
12994 
12995             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
12996               KCC=MINT(2)+4
12997             ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
12998      $        (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
12999               IF(ICOL1.EQ.JCOL1) THEN
13000                 JS=1
13001                 MINT(21)=KFF1
13002                 MINT(22)=KFF2
13003               ELSE
13004                 JS=2
13005                 MINT(21)=KFF2
13006                 MINT(22)=KFF1
13007               ENDIF
13008               IF(MCOL.EQ.0) THEN
13009         
13010               ELSE
13011                 KCC=4
13012               ENDIF
13013             ENDIF
13014           ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
13015      $      (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
13016             IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
13017      $        (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
13018               IF(MINT(15).EQ.21) JS=2
13019               KCC=MINT(2)+6
13020               IF(MINT(15).EQ.21) KCC=KCC+2
13021               IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
13022               IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
13023               IF(JCOL1.EQ.2) THEN
13024                 MINT(20+JS)=KFF2
13025                 MINT(23-JS)=KFF1
13026               ELSE
13027                 MINT(20+JS)=KFF1
13028                 MINT(23-JS)=KFF2
13029               ENDIF
13030             ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
13031      $        (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
13032               IF(MINT(15).EQ.21) JS=2
13033               KCC=15+JS
13034               KCS=ISIGN(1,MINT(14+JS))
13035               IF(JCOL1.EQ.0) THEN
13036                 MINT(23-JS)=KFF1
13037                 MINT(20+JS)=KFF2
13038               ELSE
13039                 MINT(23-JS)=KFF2
13040                 MINT(20+JS)=KFF1
13041               ENDIF
13042             ENDIF
13043           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13044      $      JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
13045             IF(PYR(0).GT.0.5D0) JS=2             
13046             KCC=21
13047             MINT(20+JS)=KFF1
13048             MINT(23-JS)=KFF2
13049           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13050      $      ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
13051      $      ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
13052             IF(PYR(0).GT.0.5D0) JS=2
13053             KCC=22+JS
13054             KCS=(-1)**INT(1.5D0+PYR(0))
13055             IF(JCOL1.EQ.0) THEN
13056               MINT(23-JS)=KFF1
13057               MINT(20+JS)=KFF2
13058             ELSE
13059               MINT(23-JS)=KFF2
13060               MINT(20+JS)=KFF1
13061             ENDIF
13062           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13063      $      ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
13064      $      ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
13065 C....two choices, 0 or 2 depending upon mother properties
13066             IF(MCOL.EQ.2) THEN
13067               KCS=(-1)**INT(1.5D0+PYR(0))
13068               KCC=MINT(2)+10
13069               IF(JCOL1.EQ.1) THEN
13070                 MINT(21)=KFF1*KCS
13071                 MINT(22)=KFF2*KCS
13072               ELSE
13073                 MINT(22)=KFF1*KCS
13074                 MINT(21)=KFF2*KCS
13075               ENDIF
13076 c              MINT(20+JS)=KFF1*KCS
13077 c              MINT(23-JS)=KFF2*KCS
13078             ELSEIF(MCOL.EQ.0) THEN
13079               KCC=21
13080               MINT(20+JS)=KFF1*KCS
13081               MINT(23-JS)=KFF2*KCS
13082             ENDIF
13083 
13084           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13085      $      JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
13086 C....two choices, 0 or 2 depending upon mother properties
13087             IF(MCOL.EQ.0) THEN
13088               KCC=21
13089               IF(PYR(0).GT.0.5D0) JS=2
13090               MINT(20+JS)=KFF1
13091               MINT(23-JS)=KFF2               
13092             ELSEIF(MCOL.EQ.2) THEN
13093               IF(PYR(0).GT.0.5D0) JS=2
13094               KCC=MINT(2)+12
13095               KCS=(-1)**INT(1.5D0+PYR(0))
13096               MINT(20+JS)=KFF1
13097               MINT(23-JS)=KFF2
13098             ENDIF
13099           ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
13100      $      (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
13101             KCC=MINT(2) 
13102             IF(PYR(0).GT.0.5D0) JS=2
13103             MINT(20+JS)=KFF1
13104             MINT(23-JS)=KFF2                          
13105           ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
13106             KCC=20
13107             IF(PYR(0).GT.0.5D0) JS=2
13108             MINT(20+JS)=KFF1
13109             MINT(23-JS)=KFF2                          
13110           ELSE
13111             CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
13112           ENDIF
13113           IF(ISUBSV.EQ.482) KFRES=0
13114         ENDIF 
13115       ENDIF
13116  
13117       IF(ISET(ISUB).EQ.11) THEN
13118 C...Store documentation for user-defined processes
13119         BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
13120         KUPPO(1)=MINT(83)+5
13121         KUPPO(2)=MINT(83)+6
13122         I=MINT(83)+6
13123         DO 470 IUP=3,NUP
13124           KUPPO(IUP)=0
13125           IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
13126             IDOC=IDOC-1
13127             MINT(4)=MINT(4)-1
13128             GOTO 470
13129           ENDIF
13130           I=I+1
13131           KUPPO(IUP)=I
13132           K(I,1)=21
13133           K(I,2)=IDUP(IUP)
13134           IF(IDUP(IUP).EQ.0) K(I,2)=90
13135           K(I,3)=0
13136           IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
13137           K(I,4)=0
13138           K(I,5)=0
13139           DO 460 J=1,5
13140             P(I,J)=PUP(J,IUP)
13141   460     CONTINUE
13142           V(I,5)=VTIMUP(IUP)
13143   470   CONTINUE
13144         CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
13145      &  -BEZUP)
13146  
13147 C...Store final state partons for user-defined processes
13148         N=IPU2
13149         DO 490 IUP=3,NUP
13150           N=N+1
13151           K(N,1)=1
13152           IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
13153           K(N,2)=IDUP(IUP)
13154           IF(IDUP(IUP).EQ.0) K(N,2)=90
13155           IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
13156             K(N,3)=KUPPO(IUP)
13157           ELSE
13158             K(N,3)=MINT(84)+MOTHUP(1,IUP)
13159           ENDIF
13160           K(N,4)=0
13161           K(N,5)=0
13162 C...Search for daughters of intermediate colourless particles.
13163           IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
13164             DO 475 IUPDAU=IUP+1,NUP
13165               IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
13166      &        N+IUPDAU-IUP
13167               IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
13168   475       CONTINUE
13169           ENDIF
13170           DO 480 J=1,5
13171             P(N,J)=PUP(J,IUP)
13172   480     CONTINUE
13173           V(N,5)=VTIMUP(IUP)
13174   490   CONTINUE
13175         CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
13176  
13177 C...Arrange colour flow for user-defined processes
13178         NLBL=0
13179         DO 540 IUP1=1,NUP
13180           I1=MINT(84)+IUP1
13181           IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
13182           IF(K(I1,1).EQ.1) K(I1,1)=3
13183           IF(K(I1,1).EQ.11) K(I1,1)=14
13184 C...Find a not yet considered colour/anticolour line.
13185           DO 530 ISDE1=1,2
13186             IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
13187             NMAT=0
13188             DO 500 ILBL=1,NLBL
13189               IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
13190   500       CONTINUE
13191             IF(NMAT.EQ.0) THEN
13192               NLBL=NLBL+1
13193               ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
13194 C...Find all others belonging to same line.
13195               I3=I1
13196               I4=0
13197               DO 520 IUP2=IUP1+1,NUP
13198                 I2=MINT(84)+IUP2
13199                 DO 510 ISDE2=1,2
13200                   IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
13201                     IF(ISDE2.EQ.ISDE1) THEN
13202                       K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
13203                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
13204                       I3=I2
13205                     ELSEIF(I4.NE.0) THEN
13206                       K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
13207                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
13208                       I4=I2
13209                     ELSEIF(IUP2.LE.2) THEN
13210                       K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
13211                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
13212                       I4=I2
13213                     ELSE
13214                       K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
13215                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
13216                       I4=I2
13217                     ENDIF
13218                   ENDIF
13219   510           CONTINUE
13220   520         CONTINUE
13221             ENDIF
13222   530     CONTINUE
13223   540   CONTINUE
13224  
13225       ELSEIF(IDOC.EQ.7) THEN
13226 C...Resonance not decaying; store kinematics
13227         I=MINT(83)+7
13228         K(IPU3,1)=1
13229         K(IPU3,2)=KFRES
13230         K(IPU3,3)=I
13231         P(IPU3,4)=SHUSER
13232         P(IPU3,5)=SHUSER
13233         K(I,1)=21
13234         K(I,2)=KFRES
13235         P(I,4)=SHUSER
13236         P(I,5)=SHUSER
13237         N=IPU3
13238         MINT(21)=KFRES
13239         MINT(22)=0
13240  
13241 C...Special cases: colour flow in coloured resonances
13242         KCRES=PYCOMP(KFRES)
13243         IF(KCHG(KCRES,2).NE.0) THEN
13244           K(IPU3,1)=3
13245           DO 550 J=1,2
13246             JC=J
13247             IF(KCS.EQ.-1) JC=3-J
13248             IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13249      &      MINT(84)+ICOL(KCC,1,JC)
13250             IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13251      &      MINT(84)+ICOL(KCC,2,JC)
13252             IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13253      &      MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13254   550     CONTINUE
13255         ELSE
13256           K(IPU1,4)=IPU2
13257           K(IPU1,5)=IPU2
13258           K(IPU2,4)=IPU1
13259           K(IPU2,5)=IPU1
13260         ENDIF
13261  
13262       ELSEIF(IDOC.EQ.8) THEN
13263 C...2 -> 2 processes: store outgoing partons in their CM-frame
13264         DO 560 JT=1,2
13265           I=MINT(84)+2+JT
13266           KCA=PYCOMP(MINT(20+JT))
13267           K(I,1)=1
13268           IF(KCHG(KCA,2).NE.0) K(I,1)=3
13269           K(I,2)=MINT(20+JT)
13270           K(I,3)=MINT(83)+IDOC+JT-2
13271           KFAA=IABS(K(I,2))
13272           IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13273             P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13274           ELSE
13275             P(I,5)=PYMASS(K(I,2))
13276           ENDIF
13277           IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13278      &    P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13279   560   CONTINUE
13280         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13281           KFA1=IABS(MINT(21))
13282           KFA2=IABS(MINT(22))
13283           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13284      &    THEN
13285             MINT(51)=1
13286             RETURN
13287           ENDIF
13288           P(IPU3,5)=0D0
13289           P(IPU4,5)=0D0
13290         ENDIF
13291         P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13292         P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13293         P(IPU4,4)=SHR-P(IPU3,4)
13294         P(IPU4,3)=-P(IPU3,3)
13295         N=IPU4
13296         MINT(7)=MINT(83)+7
13297         MINT(8)=MINT(83)+8
13298  
13299 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13300         CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13301  
13302       ELSEIF(IDOC.EQ.9) THEN
13303 C...2 -> 3 processes: store outgoing partons in their CM frame
13304         DO 570 JT=1,2
13305           I=MINT(84)+2+JT
13306           KCA=PYCOMP(MINT(20+JT))
13307           K(I,1)=1
13308           IF(KCHG(KCA,2).NE.0) K(I,1)=3
13309           K(I,2)=MINT(20+JT)
13310           K(I,3)=MINT(83)+IDOC+JT-3
13311           JTA=JT
13312 C...t and b in opposide order in event list as compared to
13313 C...matrix element?
13314           IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13315           IF(IABS(K(I,2)).LE.22) THEN
13316             P(I,5)=PYMASS(K(I,2))
13317           ELSE
13318             P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13319           ENDIF
13320           PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13321           P(I,1)=PT*COS(VINT(198+5*JTA))
13322           P(I,2)=PT*SIN(VINT(198+5*JTA))
13323   570   CONTINUE
13324         K(IPU5,1)=1
13325         K(IPU5,2)=KFRES
13326         K(IPU5,3)=MINT(83)+IDOC
13327         P(IPU5,5)=SHR
13328         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13329         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13330         PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13331         PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13332         PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13333         PMT3=SQRT(PMS3)
13334         P(IPU5,3)=PMT3*SINH(VINT(211))
13335         P(IPU5,4)=PMT3*COSH(VINT(211))
13336         PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13337         SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13338         IF(SQL12.LE.0D0) THEN
13339           MINT(51)=1
13340           RETURN
13341         ENDIF
13342         P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13343      &  VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13344         P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13345         IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13346 C...t and b in opposide order in event list as compared to
13347 C...matrix element
13348           P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13349      &    VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13350           P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13351         END IF
13352         P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13353         P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13354         MINT(23)=KFRES
13355         N=IPU5
13356         MINT(7)=MINT(83)+7
13357         MINT(8)=MINT(83)+8
13358  
13359       ELSEIF(IDOC.EQ.11) THEN
13360 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13361         PHI(1)=PARU(2)*PYR(0)
13362         PHI(2)=PHI(1)-PHIR
13363         DO 580 JT=1,2
13364           I=MINT(84)+2+JT
13365           K(I,1)=1
13366           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13367           K(I,2)=MINT(20+JT)
13368           K(I,3)=MINT(83)+IDOC+JT-2
13369           P(I,5)=PYMASS(K(I,2))
13370           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13371             MINT(51)=1
13372             RETURN
13373           ENDIF
13374           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13375           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13376           P(I,1)=PTABS*COS(PHI(JT))
13377           P(I,2)=PTABS*SIN(PHI(JT))
13378           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13379           P(I,4)=0.5D0*SHPR*Z(JT)
13380           IZW=MINT(83)+6+JT
13381           K(IZW,1)=21
13382           K(IZW,2)=23
13383           IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13384           K(IZW,3)=IZW-2
13385           P(IZW,1)=-P(I,1)
13386           P(IZW,2)=-P(I,2)
13387           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13388           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13389           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13390   580   CONTINUE
13391         I=MINT(83)+9
13392         K(IPU5,1)=1
13393         K(IPU5,2)=KFRES
13394         K(IPU5,3)=I
13395         P(IPU5,5)=SHR
13396         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13397         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13398         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13399         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13400         K(I,1)=21
13401         K(I,2)=KFRES
13402         DO 590 J=1,5
13403           P(I,J)=P(IPU5,J)
13404   590   CONTINUE
13405         N=IPU5
13406         MINT(23)=KFRES
13407  
13408       ELSEIF(IDOC.EQ.12) THEN
13409 C...Z0 and W+/- scattering: store bosons and outgoing partons
13410         PHI(1)=PARU(2)*PYR(0)
13411         PHI(2)=PHI(1)-PHIR
13412         JTRAN=INT(1.5D0+PYR(0))
13413         DO 600 JT=1,2
13414           I=MINT(84)+2+JT
13415           K(I,1)=1
13416           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13417           K(I,2)=MINT(20+JT)
13418           K(I,3)=MINT(83)+IDOC+JT-2
13419           P(I,5)=PYMASS(K(I,2))
13420           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13421           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13422           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13423           P(I,1)=PTABS*COS(PHI(JT))
13424           P(I,2)=PTABS*SIN(PHI(JT))
13425           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13426           P(I,4)=0.5D0*SHPR*Z(JT)
13427           IZW=MINT(83)+6+JT
13428           K(IZW,1)=21
13429           IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13430             K(IZW,2)=23
13431           ELSE
13432             K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13433           ENDIF
13434           K(IZW,3)=IZW-2
13435           P(IZW,1)=-P(I,1)
13436           P(IZW,2)=-P(I,2)
13437           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13438           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13439           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13440           IPU=MINT(84)+4+JT
13441           K(IPU,1)=3
13442           K(IPU,2)=KFPR(ISUB,JT)
13443           IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13444           IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13445           K(IPU,3)=MINT(83)+8+JT
13446           IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13447             P(IPU,5)=PYMASS(K(IPU,2))
13448           ELSE
13449             P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13450           ENDIF
13451           MINT(22+JT)=K(IPU,2)
13452   600   CONTINUE
13453 C...Find rotation and boost for hard scattering subsystem
13454         I1=MINT(83)+7
13455         I2=MINT(83)+8
13456         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13457         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13458         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13459         GAMCM=(P(I1,4)+P(I2,4))/SHR
13460         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13461         PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13462         PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13463         PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13464         THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13465         PHICM=PYANGL(PX,PY)
13466 C...Store hard scattering subsystem. Rotate and boost it
13467         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13468      &  P(IPU6,5)**2
13469         PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13470         CTHWZ=VINT(23)
13471         STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13472         PHIWZ=VINT(24)-PHICM
13473         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13474         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13475         P(IPU5,3)=PABS*CTHWZ
13476         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13477         P(IPU6,1)=-P(IPU5,1)
13478         P(IPU6,2)=-P(IPU5,2)
13479         P(IPU6,3)=-P(IPU5,3)
13480         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13481         CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13482         DO 620 JT=1,2
13483           I1=MINT(83)+8+JT
13484           I2=MINT(84)+4+JT
13485           K(I1,1)=21
13486           K(I1,2)=K(I2,2)
13487           DO 610 J=1,5
13488             P(I1,J)=P(I2,J)
13489   610     CONTINUE
13490   620   CONTINUE
13491         N=IPU6
13492         MINT(7)=MINT(83)+9
13493         MINT(8)=MINT(83)+10
13494       ENDIF
13495  
13496       IF(ISET(ISUB).EQ.11) THEN
13497       ELSEIF(IDOC.GE.8) THEN
13498 C...Store colour connection indices
13499         DO 630 J=1,2
13500           JC=J
13501           IF(KCS.EQ.-1) JC=3-J
13502           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13503      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13504           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13505      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13506           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13507      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13508           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13509      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13510   630   CONTINUE
13511  
13512 C...Copy outgoing partons to documentation lines
13513         IMAX=2
13514         IF(IDOC.EQ.9) IMAX=3
13515         DO 650 I=1,IMAX
13516           I1=MINT(83)+IDOC-IMAX+I
13517           I2=MINT(84)+2+I
13518           K(I1,1)=21
13519           K(I1,2)=K(I2,2)
13520           IF(IDOC.LE.9) K(I1,3)=0
13521           IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13522           DO 640 J=1,5
13523             P(I1,J)=P(I2,J)
13524   640     CONTINUE
13525   650   CONTINUE
13526  
13527       ELSEIF(IDOC.EQ.9) THEN
13528 C...Store colour connection indices
13529         DO 660 J=1,2
13530           JC=J
13531           IF(KCS.EQ.-1) JC=3-J
13532           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13533      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13534      &    MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13535           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13536      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13537      &    MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13538           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13539      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13540           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13541      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13542   660   CONTINUE
13543  
13544 C...Copy outgoing partons to documentation lines
13545         DO 680 I=1,3
13546           I1=MINT(83)+IDOC-3+I
13547           I2=MINT(84)+2+I
13548           K(I1,1)=21
13549           K(I1,2)=K(I2,2)
13550           K(I1,3)=0
13551           DO 670 J=1,5
13552             P(I1,J)=P(I2,J)
13553   670     CONTINUE
13554   680   CONTINUE
13555       ENDIF
13556  
13557 C...Copy outgoing partons to list of allowed radiators.
13558       NPART=0
13559       IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13560         DO 690 I=MINT(84)+3,N
13561           NPART=NPART+1
13562           IPART(NPART)=I
13563           PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13564   690   CONTINUE
13565       ENDIF
13566  
13567 C...Low-pT events: remove gluons used for string drawing purposes
13568       IF(ISUB.EQ.95) THEN
13569         IF(MINT(35).LE.1) THEN
13570           K(IPU3,1)=K(IPU3,1)+10
13571           K(IPU4,1)=K(IPU4,1)+10
13572         ENDIF
13573         DO 700 J=41,66
13574           VINTSV(J)=VINT(J)
13575           VINT(J)=0D0
13576   700   CONTINUE
13577         DO 720 I=MINT(83)+5,MINT(83)+8
13578           DO 710 J=1,5
13579             P(I,J)=0D0
13580   710     CONTINUE
13581   720   CONTINUE
13582       ENDIF
13583  
13584       RETURN
13585       END
13586  
13587 C***********************************************************************
13588  
13589 C...PYEVOL
13590 C...Handles intertwined pT-ordered spacelike initial-state parton
13591 C...and multiple interactions.
13592  
13593       SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13594 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13595 C...MODE =  0 : (Re-)initialize ISR/MI evolution.
13596 C...Mode =  1 : Evolve event from PT2MAX to PT2MIN.
13597  
13598 C...Double precision and integer declarations.
13599       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13600       IMPLICIT INTEGER(I-N)
13601       INTEGER PYK,PYCHGE,PYCOMP
13602 C...External
13603       EXTERNAL PYALPS
13604       DOUBLE PRECISION PYALPS
13605 C...Parameter statement for maximum size of showers.
13606       PARAMETER (MAXNUR=1000)
13607 C...Commonblocks.
13608       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13609       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13610       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13611       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13612       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13613       COMMON/PYINT1/MINT(400),VINT(400)
13614       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13615       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13616       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13617      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13618      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
13619       COMMON/PYCTAG/NCT,MCT(4000,2)
13620       COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13621      &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13622       COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13623 C...Max size of hard system = HEPEUP size
13624       INTEGER MAXNUP
13625       PARAMETER (MAXNUP=500)
13626 C...Local arrays and saved variables.
13627       DIMENSION VINTSV(11:80),KSAV(MAXNUP,5),PSAV(MAXNUP,5),
13628      &     VSAV(MAXNUP,5),SHAT(240)
13629       SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13630      &     ,PSAV,KSAV,VSAV
13631  
13632       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13633      &     /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13634  
13635 C----------------------------------------------------------------------
13636 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13637 C...done only once per event, while MODE=0 is repeated each time the
13638 C...evolution needs to be restarted.
13639       IF (MODE.EQ.-1) THEN
13640         ISUBHD=MINT(1)
13641         NSAV=N
13642         NPARTS=NPART
13643 C...Store hard scattering variables
13644         M15SV=MINT(15)
13645         M16SV=MINT(16)
13646         M21SV=MINT(21)
13647         M22SV=MINT(22)
13648         DO 100 J=11,80
13649           VINTSV(J)=VINT(J)
13650   100   CONTINUE
13651         DO 120 J=1,5
13652           DO 110 IS=1,NSAV-MINT(84)
13653             I=IS+MINT(84)
13654             PSAV(IS,J)=P(I,J)
13655             KSAV(IS,J)=K(I,J)
13656             VSAV(IS,J)=V(I,J)
13657   110     CONTINUE
13658   120   CONTINUE
13659  
13660 C...Set shat for hardest scattering
13661         SHAT(1)=VINT(44)
13662         IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13663      &       *VINT(2)
13664  
13665 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13666         RMC=PMAS(4,1)
13667         RMB=PMAS(5,1)
13668         ALAM4=PARP(61)
13669         IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13670         IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13671         ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13672  
13673 C----------------------------------------------------------------------
13674 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13675 C...interaction initiators, with no previous evolution. Check the input
13676 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13677 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13678 C...smaller than the CM energy / 2.)
13679       ELSEIF (MODE.EQ.0) THEN
13680 C...Reset counters and switches
13681         N=NSAV
13682         NPART=NPARTS
13683         MINT(30)=0
13684         MINT(31)=1
13685         MINT(36)=1
13686 C...Reset hard scattering variables
13687         MINT(1)=ISUBHD
13688         DO 130 J=11,80
13689           VINT(J)=VINTSV(J)
13690   130   CONTINUE
13691         DO 150 J=1,5
13692           DO 140 IS=1,NSAV-MINT(84)
13693             I=IS+MINT(84)
13694             P(I,J)=PSAV(IS,J)
13695             K(I,J)=KSAV(IS,J)
13696             V(I,J)=VSAV(IS,J)
13697             P(MINT(83)+4+IS,J)=PSAV(IS,J)
13698             V(MINT(83)+4+IS,J)=VSAV(IS,J)
13699   140     CONTINUE
13700   150   CONTINUE
13701 C...Reset statistics on activity in event.
13702         DO 160 J=351,359
13703           MINT(J)=0
13704           VINT(J)=0D0
13705   160   CONTINUE
13706 C...Reset extra companion reweighting factor
13707         VINT(140)=1D0
13708  
13709 C...We do not generate MI for soft process (ISUB=95), but the
13710 C...initialization must be done regardless, for later purposes.
13711         MINT(36)=1
13712  
13713 C...Initialize multiple interactions.
13714         CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13715         IF(MINT(51).NE.0) RETURN
13716  
13717 C...Decide whether quarks in hard scattering were valence or sea
13718         PT2HD=VINT(54)
13719         DO 170 JS=1,2
13720           MINT(30)=JS
13721           CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13722           IF(MINT(51).NE.0) RETURN
13723   170   CONTINUE
13724  
13725 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13726         VINT(18)=0D0
13727         PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13728         IF (MSTP(70).EQ.2) THEN
13729 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13730           VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13731         ELSEIF (MSTP(70).EQ.3) THEN
13732 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73) 
13733           ALPHA0 = MAX(1D-6,PARP(73))
13734           Q20 = ALAM3**2/PARP(64)
13735           IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13736           VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13737         ENDIF
13738 C...Also store PT2MIN in VINT(17).
13739   180   VINT(17)=PT2MIN
13740  
13741 C...Set FS masses zero now.
13742         VINT(63)=0D0
13743         VINT(64)=0D0
13744  
13745 C...Initialize IS showers with VINT(56) as max scale.
13746         PT2ISR=VINT(56)
13747         PT20=PT2MIN
13748         IF (MSTP(70).EQ.0) THEN 
13749           PT20=MAX(PT2MIN,PARP(62)**2)
13750         ELSEIF (MSTP(70).EQ.1) THEN
13751           PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13752         ENDIF  
13753         CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13754         IF(MINT(51).NE.0) RETURN
13755  
13756         RETURN
13757  
13758 C----------------------------------------------------------------------
13759 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13760       ELSEIF (MODE.EQ.1) THEN
13761  
13762 C...Skip if no phase space.
13763   190   IF (PT2MAX.LE.PT2MIN) GOTO 330
13764  
13765 C...Starting pT2 max scale (to be udpated successively).
13766         PT2CMX=PT2MAX
13767  
13768 C...Evolve two sides of the event to find which branches at highest pT.
13769   200   JSMX=-1
13770         MIMX=0
13771         PT2MX=0D0
13772  
13773 C...Loop over current shower initiators.
13774         IF (MSTP(61).GE.1) THEN
13775           DO 230 MI=1,MINT(31)
13776             IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13777             ISUB=96
13778             IF (MI.EQ.1) ISUB=ISUBHD
13779             MINT(1)=ISUB
13780             MINT(36)=MI
13781 C...Set up shat, initiator x values, and x remaining in BR.
13782             VINT(44)=SHAT(MI)
13783             VINT(141)=XMI(1,MI)
13784             VINT(142)=XMI(2,MI)
13785             VINT(143)=1D0
13786             VINT(144)=1D0
13787             DO 210 JI=1,MINT(31)
13788               IF (JI.EQ.MINT(36)) GOTO 210
13789               VINT(143)=VINT(143)-XMI(1,JI)
13790               VINT(144)=VINT(144)-XMI(2,JI)
13791   210       CONTINUE
13792 C...Loop over sides.
13793 C...Generate trial branchings for this interaction. The hardest
13794 C...branching so far is automatically updated if necessary in /PYISMX/.
13795             DO 220 JS=1,2
13796               MINT(30)=JS
13797               PT20=PT2MIN
13798               IF (MSTP(70).EQ.0) THEN 
13799                 PT20=MAX(PT2MIN,PARP(62)**2)
13800               ELSEIF (MSTP(70).EQ.1) THEN
13801                 PT20=MAX(PT2MIN,
13802      &              (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13803               ENDIF  
13804               CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13805               IF (MINT(51).NE.0) RETURN
13806   220       CONTINUE
13807   230     CONTINUE
13808         ENDIF
13809  
13810 C...Generate trial additional interaction.
13811         MINT(36)=MINT(31)+1
13812   240   IF (MOD(MSTP(81),10).GE.1) THEN
13813           MINT(1)=96
13814 C...Set up X remaining in BR.
13815           VINT(143)=1D0
13816           VINT(144)=1D0
13817           DO 250 JI=1,MINT(31)
13818             VINT(143)=VINT(143)-XMI(1,JI)
13819             VINT(144)=VINT(144)-XMI(2,JI)
13820   250     CONTINUE
13821 C...Generate trial interaction
13822   260     CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13823           IF (MINT(51).EQ.1) RETURN
13824         ENDIF
13825  
13826 C...And the winner is:
13827         IF (PT2MX.LT.PT2MIN) THEN
13828           GOTO 330
13829         ELSEIF (JSMX.EQ.0) THEN
13830 C...Accept additional interaction (may still fail).
13831           CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13832           IF(MINT(51).NE.0) RETURN
13833           IF (IFAIL.EQ.0) THEN
13834             SHAT(MINT(36))=VINT(44)
13835 C...Decide on flavours (valence/sea/companion).
13836             DO 270 JS=1,2
13837               MINT(30)=JS
13838               CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13839               IF(MINT(51).NE.0) RETURN
13840   270       CONTINUE
13841           ENDIF
13842         ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13843 C...Reconstruct kinematics of acceptable ISR branching.
13844 C...Set up shat, initiator x values, and x remaining in BR.
13845           MINT(30)=JSMX
13846           MINT(36)=MIMX
13847           VINT(44)=SHAT(MINT(36))
13848           VINT(141)=XMI(1,MINT(36))
13849           VINT(142)=XMI(2,MINT(36))
13850           VINT(143)=1D0
13851           VINT(144)=1D0
13852           DO 280 JI=1,MINT(31)
13853             IF (JI.EQ.MINT(36)) GOTO 280
13854             VINT(143)=VINT(143)-XMI(1,JI)
13855             VINT(144)=VINT(144)-XMI(2,JI)
13856   280     CONTINUE
13857           PT2NEW=PT2MX
13858           CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13859           IF (MINT(51).EQ.1) RETURN
13860         ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13861 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13862           MINT(354)=MINT(354)+1
13863           VINT(354)=VINT(354)+SQRT(PT2MX)
13864           IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13865           MJOIND(JSMX-2,MJN1MX)=MJN2MX
13866           MJOIND(JSMX-2,MJN2MX)=MJN1MX
13867         ENDIF
13868  
13869 C...Update PT2 iteration scale.
13870         PT2CMX=PT2MX
13871  
13872 C...Loop back to continue evolution.
13873         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13874           CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13875         ELSE
13876           IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13877         ENDIF
13878  
13879 C----------------------------------------------------------------------
13880 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13881       ELSEIF (MODE.EQ.2) THEN
13882  
13883 C...Revert to "ordinary" meanings of some parameters.
13884   290   DO 310 JS=1,2
13885           MINT(12+JS)=K(IMI(JS,1,1),2)
13886           VINT(140+JS)=XMI(JS,1)
13887           IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13888           VINT(142+JS)=1D0
13889           DO 300 MI=1,MINT(31)
13890             VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13891   300     CONTINUE
13892   310   CONTINUE
13893  
13894 C...Restore saved quantities for hardest interaction.
13895         MINT(1)=ISUBHD
13896         MINT(15)=M15SV
13897         MINT(16)=M16SV
13898         MINT(21)=M21SV
13899         MINT(22)=M22SV
13900         DO 320 J=11,80
13901           VINT(J)=VINTSV(J)
13902   320   CONTINUE
13903  
13904       ENDIF
13905  
13906   330 RETURN
13907       END
13908 
13909 C*********************************************************************
13910  
13911 C...PYSSPA
13912 C...Generates spacelike parton showers.
13913  
13914       SUBROUTINE PYSSPA(IPU1,IPU2)
13915  
13916 C...Double precision and integer declarations.
13917       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13918       IMPLICIT INTEGER(I-N)
13919       INTEGER PYK,PYCHGE,PYCOMP
13920       PARAMETER (MAXNUR=1000)
13921 C...Commonblocks.
13922       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13923       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13924       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13925       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13926       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13927       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13928       COMMON/PYINT1/MINT(400),VINT(400)
13929       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13930       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13931       COMMON/PYCTAG/NCT,MCT(4000,2)
13932       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13933      &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13934 C...Local arrays and data.
13935       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13936      &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13937      &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13938      &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13939      &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13940       DATA IS/2*0/
13941  
13942 C...Read out basic information; set global Q^2 scale.
13943       IPUS1=IPU1
13944       IPUS2=IPU2
13945       ISUB=MINT(1)
13946       Q2MX=VINT(56)
13947       VINT2R=VINT(2)*VINT(143)*VINT(144)
13948       IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13949      &MIN(VINT2R,PARP(67)*VINT(56))
13950       FCQ2MX=1D0
13951  
13952 C...Define which processes ME corrections have been implemented for.
13953       MECOR=0
13954       IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13955         IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13956      &  ISUB.EQ.144) MECOR=1
13957         IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13958         IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13959       ENDIF
13960  
13961 C...Initialize QCD evolution and check phase space.
13962       Q2MNC=PARP(62)**2
13963       Q2MNCS(1)=Q2MNC
13964       Q2MNCS(2)=Q2MNC
13965       IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13966         Q0S=PARP(15)**2
13967         PS=VINT(3)**2
13968         Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13969      &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13970         Q2INT=SQRT(Q0S*Q2EFF)
13971         Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13972       ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13973         Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13974       ENDIF
13975       IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13976         Q0S=PARP(15)**2
13977         PS=VINT(4)**2
13978         Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13979      &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13980         Q2INT=SQRT(Q0S*Q2EFF)
13981         Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13982       ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13983         Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13984       ENDIF
13985       MCEV=0
13986       ALAMS=PARU(112)
13987       PARU(112)=PARP(61)
13988       FQ2C=1D0
13989       TCMX=0D0
13990       IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13991         MCEV=1
13992         IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13993         IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13994         TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13995         IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13996      &  MCEV=0
13997       ENDIF
13998  
13999 C...Initialize QED evolution and check phase space.
14000       MEEV=0
14001       XEE=1D-10
14002       SPME=PMAS(11,1)**2
14003       IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
14004      &SPME=PMAS(13,1)**2
14005       IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
14006      &SPME=PMAS(15,1)**2
14007       Q2MNE=MAX(PARP(68)**2,2D0*SPME)
14008       TEMX=0D0
14009       FWTE=10D0
14010       IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
14011         MEEV=1
14012         TEMX=LOG(Q2MX/SPME)
14013         IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
14014       ENDIF
14015       IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14016         MEEV=2
14017         TEMX=TCMX
14018         FWTE=1D0
14019       ENDIF
14020       IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
14021  
14022 C...Loopback point in case of failure to reconstruct kinematics.
14023       NS=N
14024       NPARTS=NPART
14025       LOOP=0      
14026       MNT352=MINT(352)
14027       MNT353=MINT(353)
14028       VNT352=VINT(352)
14029       VNT353=VINT(353)
14030   100 LOOP=LOOP+1
14031       IF(LOOP.GT.100) THEN
14032         MINT(51)=1
14033         RETURN
14034       ENDIF
14035       N=NS
14036       NPART=NPARTS
14037       MINT(352)=MNT352
14038       MINT(353)=MNT353
14039       VINT(352)=VNT352
14040       VINT(353)=VNT353
14041  
14042 C...Initial values: flavours, momenta, virtualities.
14043       DO 120 JT=1,2
14044         MORE(JT)=1
14045         KFBEAM(JT)=MINT(10+JT)
14046         IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
14047         KFLS(JT)=MINT(14+JT)
14048         KFLS(JT+2)=KFLS(JT)
14049         XS(JT)=VINT(40+JT)
14050         IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
14051         IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
14052         ZS(JT)=1D0
14053         Q2S(JT)=FCQ2MX*Q2MX
14054         DQ2(JT)=0D0
14055         TEVCSV(JT)=TCMX
14056         ALAM(JT)=PARP(61)
14057         THE2(JT)=1D0
14058         TEVESV(JT)=TEMX
14059         MCESV(JT)=0
14060 C...Calculate initial parton distribution weights.
14061         MINT(105)=MINT(102+JT)
14062         MINT(109)=MINT(106+JT)
14063         VINT(120)=VINT(2+JT)
14064         IF(XS(JT).LT.1D0-XEE) THEN
14065           IF(MINT(31).GE.2) MINT(30)=JT
14066           IF(MSTP(57).LE.1) THEN
14067             CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14068           ELSE
14069             CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14070           ENDIF
14071         ENDIF
14072         DO 110 KFL=-25,25
14073           XFS(JT,KFL)=XFB(KFL)
14074   110   CONTINUE
14075 C...Special kinematics check for c/b quarks (that g -> c cbar or
14076 C...b bbar kinematically possible).
14077       KFLCB=IABS(KFLS(JT))
14078       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14079         IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
14080           MINT(51)=1
14081           RETURN
14082         ENDIF
14083       ENDIF
14084   120 CONTINUE
14085       DSH=VINT(44)
14086       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
14087  
14088 C...Find if interference with final state partons.
14089       MFIS=0
14090       IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
14091       IF(MFIS.NE.0) THEN
14092         DO 140 I=1,2
14093           KCFI(I)=0
14094           KCA=PYCOMP(IABS(KFLS(I)))
14095           IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
14096           NFIS(I)=0
14097           IF(KCFI(I).NE.0) THEN
14098             IF(I.EQ.1) IPFS=IPUS1
14099             IF(I.EQ.2) IPFS=IPUS2
14100             DO 130 J=1,2
14101               ICSI=MOD(K(IPFS,3+J),MSTU(5))
14102               IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
14103      &        (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
14104                 NFIS(I)=NFIS(I)+1
14105                 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
14106      &          P(ICSI,2)**2))
14107                 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
14108               ENDIF
14109   130       CONTINUE
14110           ENDIF
14111   140   CONTINUE
14112         IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
14113       ENDIF
14114  
14115 C...Pick up leg with highest virtuality.
14116       JTOLD=1
14117   150 N=N+1
14118       JT=1
14119       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
14120       IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
14121       IF(MORE(JT).EQ.0) JT=3-JT
14122       JTOLD=JT
14123       KFLB=KFLS(JT)
14124       XB=XS(JT)
14125       DO 160 KFL=-25,25
14126         XFB(KFL)=XFS(JT,KFL)
14127   160 CONTINUE
14128       DSHR=2D0*SQRT(DSH)
14129       DSHZ=DSH/ZS(JT)
14130  
14131 C...Check if allowed to branch.
14132       MCEV=0
14133       IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
14134         MCEV=1
14135         XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
14136         IF(XB.GE.1D0-2D0*XEC) MCEV=0
14137       ENDIF
14138       MEEV=0
14139       IF(MINT(44+JT).EQ.3) THEN
14140         MEEV=1
14141         IF(XB.GE.1D0-2D0*XEE) MEEV=0
14142         IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
14143      &  MEEV=0
14144 C***Currently kill QED shower for resolved photoproduction.
14145         IF(MINT(18+JT).EQ.1) MEEV=0
14146 C***Currently kill shower for W inside electron.
14147         IF(IABS(KFLB).EQ.24) THEN
14148           MCEV=0
14149           MEEV=0
14150         ENDIF
14151       ENDIF
14152       IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
14153      &MEEV=2
14154       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14155         Q2B=0D0
14156         GOTO 260
14157       ENDIF
14158  
14159 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
14160       Q2B=Q2S(JT)
14161       TEVCB=TEVCSV(JT)
14162       TEVEB=TEVESV(JT)
14163       IF(MSTP(62).LE.1) THEN
14164         IF(ZS(JT).GT.0.99999D0) THEN
14165           Q2B=Q2S(JT)
14166         ELSE
14167           Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
14168      &    (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
14169      &    8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
14170         ENDIF
14171         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14172         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14173       ENDIF
14174       IF(MCEV.EQ.1) THEN
14175         ALSDUM=PYALPS(FQ2C*Q2B)
14176         TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
14177         ALAM(JT)=PARU(117)
14178         B0=(33D0-2D0*MSTU(118))/6D0
14179       ENDIF
14180       IF(MEEV.EQ.2) TEVEB=TEVCB
14181       TEVCBS=TEVCB
14182       TEVEBS=TEVEB
14183  
14184 C...Select side for interference with final state partons.
14185       IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
14186         IFI=N-NS
14187         ISFI(IFI)=0
14188         IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
14189           ISFI(IFI)=1
14190         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
14191           IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
14192         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
14193           ISFI(IFI)=1
14194           IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
14195         ENDIF
14196       ENDIF
14197  
14198 C...Calculate preweighting factor for ME-corrected processes.
14199       IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14200  
14201 C...Calculate Altarelli-Parisi weights.
14202       DO 170 KFL=-25,25
14203         WTAPC(KFL)=0D0
14204         WTAPE(KFL)=0D0
14205         WTSF(KFL)=0D0
14206   170 CONTINUE
14207 C...q -> q (g or gamma emission), g -> q.
14208       IF(IABS(KFLB).LE.10) THEN
14209         WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
14210         WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
14211         EQ2=1D0/9D0
14212         IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
14213         IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
14214      &  (XEC*(1D0-XEC)))
14215         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14216           WTAPC(KFLB)=WTFF*WTAPC(KFLB)
14217           WTAPC(21)=WTGF*WTAPC(21)
14218           WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14219         ENDIF
14220 C...f -> f, gamma -> f.
14221       ELSEIF(IABS(KFLB).LE.20) THEN
14222         WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
14223         WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
14224         WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
14225         IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
14226         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14227           WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14228           WTAPE(22)=WTGF*WTAPE(22)
14229         ENDIF
14230 C...f -> g, g -> g.
14231       ELSEIF(KFLB.EQ.21) THEN
14232         WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
14233         DO 180 KFL=1,MSTP(58)
14234           WTAPC(KFL)=WTAPQ
14235           WTAPC(-KFL)=WTAPQ
14236   180   CONTINUE
14237         WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
14238         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14239           DO 190 KFL=1,MSTP(58)
14240             WTAPC(KFL)=WTFG*WTAPC(KFL)
14241             WTAPC(-KFL)=WTFG*WTAPC(-KFL)
14242   190     CONTINUE
14243           WTAPC(21)=WTGG*WTAPC(21)
14244         ENDIF
14245 C...f -> gamma, W+, W-.
14246       ELSEIF(KFLB.EQ.22) THEN
14247         WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
14248         WTAPE(11)=WTAPF
14249         WTAPE(-11)=WTAPF
14250         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14251           WTAPE(11)=WTFG*WTAPE(11)
14252           WTAPE(-11)=WTFG*WTAPE(-11)
14253         ENDIF
14254       ELSEIF(KFLB.EQ.24) THEN
14255         WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14256      &  (XEE*(XB+XEE)))/XB
14257       ELSEIF(KFLB.EQ.-24) THEN
14258         WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14259      &  (XEE*(XB+XEE)))/XB
14260       ENDIF
14261  
14262 C...Calculate parton distribution weights and sum.
14263       NTRY=0
14264   200 NTRY=NTRY+1
14265       IF(NTRY.GT.500) THEN
14266         MINT(51)=1
14267         RETURN
14268       ENDIF
14269       WTSUMC=0D0
14270       WTSUME=0D0
14271       XFBO=MAX(1D-10,XFB(KFLB))
14272       DO 210 KFL=-25,25
14273         WTSF(KFL)=XFB(KFL)/XFBO
14274         WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14275         WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14276   210 CONTINUE
14277       WTSUMC=MAX(0.0001D0,WTSUMC)
14278       WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14279  
14280 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14281       NTRY2=0
14282   220 NTRY2=NTRY2+1
14283       IF(NTRY2.GT.500) THEN
14284         MINT(51)=1
14285         RETURN
14286       ENDIF
14287       IF(MCEV.EQ.1) THEN
14288         IF(MSTP(64).LE.0) THEN
14289           TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14290         ELSEIF(MSTP(64).EQ.1) THEN
14291           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14292         ELSE
14293           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14294         ENDIF
14295       ENDIF
14296       IF(MEEV.EQ.1) THEN
14297         TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14298      &  (PARU(101)*FWTE*WTSUME*TEMX)))
14299       ELSEIF(MEEV.EQ.2) THEN
14300         TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14301       ENDIF
14302  
14303 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14304   230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14305       IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14306       IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14307 C...Ensure that Q2 is above threshold for charm/bottom.
14308       KFLCB=IABS(KFLB)
14309       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14310      &MCEV.EQ.1) THEN
14311         IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14312           Q2CB=1.1D0*PMAS(KFLCB,1)**2
14313           TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14314           FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14315         ENDIF
14316       ENDIF
14317       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14318      &MEEV.EQ.2) THEN
14319         IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14320       ENDIF
14321       MCE=0
14322       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14323       ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14324         IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14325       ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14326         IF(Q2EB.GT.Q2MNE) MCE=2
14327       ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14328         IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14329       ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14330         IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14331         IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14332       ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14333         MCE=1
14334         IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14335         IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14336       ELSE
14337         MCE=2
14338         IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14339         IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14340       ENDIF
14341  
14342 C...Evolution possibly ended. Update t values.
14343       IF(MCE.EQ.0) THEN
14344         Q2B=0D0
14345         GOTO 260
14346       ELSEIF(MCE.EQ.1) THEN
14347         Q2B=Q2CB
14348         Q2REF=FQ2C*Q2B
14349         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14350         IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14351       ELSE
14352         Q2B=Q2EB
14353         Q2REF=Q2B
14354         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14355       ENDIF
14356  
14357 C...Select flavour for branching parton.
14358       IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14359       IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14360       KFLA=-25
14361   240 KFLA=KFLA+1
14362       IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14363       IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14364       IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14365       IF(KFLA.EQ.25) THEN
14366         Q2B=0D0
14367         GOTO 260
14368       ENDIF
14369  
14370 C...Choose z value and corrective weight.
14371       WTZ=0D0
14372 C...q -> q + g or q -> q + gamma.
14373       IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14374         Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14375      &  (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14376         WTZ=0.5D0*(1D0+Z**2)
14377 C...q -> g + q.
14378       ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14379         Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14380         WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14381 C...f -> f + gamma.
14382       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14383         IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14384           Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14385      &    (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14386         ELSE
14387           Z=XB+XB*(XEE/(1D0-XEE))*
14388      &    ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14389         ENDIF
14390         WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14391 C...f -> gamma + f.
14392       ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14393         Z=XB+XB*(XEE/(1D0-XEE))*
14394      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14395         WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14396 C...f -> W+- + f.
14397       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14398         Z=XB+XB*(XEE/(1D0-XEE))*
14399      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14400         WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14401      &  (Q2B/(Q2B+PMAS(24,1)**2))
14402 C...g -> q + qbar.
14403       ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14404         Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14405         WTZ=1D0-2D0*Z*(1D0-Z)
14406 C...g -> g + g.
14407       ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14408         Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14409         WTZ=(1D0-Z*(1D0-Z))**2
14410 C...gamma -> f + fbar.
14411       ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14412         Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14413         WTZ=1D0-2D0*Z*(1D0-Z)
14414       ENDIF
14415       IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14416  
14417 C...Option with resummation of soft gluon emission as effective z shift.
14418       IF(MCE.EQ.1) THEN
14419         IF(MSTP(65).GE.1) THEN
14420           RSOFT=6D0
14421           IF(KFLB.NE.21) RSOFT=8D0/3D0
14422           Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14423           IF(Z.LE.XB) GOTO 220
14424         ENDIF
14425  
14426 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14427         IF(MSTP(64).GE.2) THEN
14428           IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14429           ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14430           IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14431           IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14432         ENDIF
14433       ENDIF
14434  
14435 C...Remove kinematically impossible branchings.
14436       UHAT=Q2B-DSH*(1D0-Z)/Z
14437       IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14438  
14439 C...Select phi angle of branching at random.
14440       PHIBR=PARU(2)*PYR(0)
14441  
14442 C...Matrix-element corrections for some processes.
14443       IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14444         IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14445           CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14446           WTZ=WTZ*WTME/WTFF
14447         ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14448           CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14449           WTZ=WTZ*WTME/WTGF
14450         ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14451           CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14452           WTZ=WTZ*WTME/WTFG
14453         ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14454           CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14455           WTZ=WTZ*WTME/WTGG
14456         ENDIF
14457       ENDIF
14458  
14459 C...Impose angular constraint in first branching from interference
14460 C...with final state partons.
14461       IF(MCE.EQ.1) THEN
14462         IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14463           THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14464           IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14465             IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14466           ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14467             IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14468           ENDIF
14469         ENDIF
14470  
14471 C...Option with angular ordering requirement.
14472         IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14473           THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14474           IF(THE2T.GT.THE2(JT)) GOTO 220
14475         ENDIF
14476       ENDIF
14477  
14478 C...Weighting with new parton distributions.
14479       MINT(105)=MINT(102+JT)
14480       MINT(109)=MINT(106+JT)
14481       VINT(120)=VINT(2+JT)
14482       IF(MINT(31).GE.2) MINT(30)=JT
14483       IF(MSTP(57).LE.1) THEN
14484         CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14485       ELSE
14486         CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14487       ENDIF
14488       XFBN=XFN(KFLB)
14489       IF(XFBN.LT.1D-20) THEN
14490         IF(KFLA.EQ.KFLB) THEN
14491           TEVCB=TEVCBS
14492           TEVEB=TEVEBS
14493           WTAPC(KFLB)=0D0
14494           WTAPE(KFLB)=0D0
14495           GOTO 200
14496         ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14497           TEVCB=0.5D0*(TEVCBS+TEVCB)
14498           GOTO 230
14499         ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14500           TEVEB=0.5D0*(TEVEBS+TEVEB)
14501           GOTO 230
14502         ELSE
14503           XFBN=1D-10
14504           XFN(KFLB)=XFBN
14505         ENDIF
14506       ENDIF
14507       DO 250 KFL=-25,25
14508         XFB(KFL)=XFN(KFL)
14509   250 CONTINUE
14510       XA=XB/Z
14511       IF(MINT(31).GE.2) MINT(30)=JT
14512       IF(MSTP(57).LE.1) THEN
14513         CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14514       ELSE
14515         CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14516       ENDIF
14517       XFAN=XFA(KFLA)
14518       IF(XFAN.LT.1D-20) GOTO 200
14519       WTSFA=WTSF(KFLA)
14520       IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14521  
14522 C...Define two hard scatterers in their CM-frame.
14523   260 IF(N.EQ.NS+2) THEN
14524         DQ2(JT)=Q2B
14525         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14526         DO 280 JR=1,2
14527           I=NS+JR
14528           IF(JR.EQ.1) IPO=IPUS1
14529           IF(JR.EQ.2) IPO=IPUS2
14530           DO 270 J=1,5
14531             K(I,J)=0
14532             P(I,J)=0D0
14533             V(I,J)=0D0
14534   270     CONTINUE
14535           K(I,1)=14
14536           K(I,2)=KFLS(JR+2)
14537           K(I,4)=IPO
14538           K(I,5)=IPO
14539           P(I,3)=DPLCM*(-1)**(JR+1)
14540           P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14541           P(I,5)=-SQRT(DQ2(JR))
14542           K(IPO,1)=14
14543           K(IPO,3)=I
14544           K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14545           K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14546           MCT(I,1)=MCT(IPO,1)
14547           MCT(I,2)=MCT(IPO,2)
14548   280   CONTINUE
14549  
14550 C...Find maximum allowed mass of timelike parton.
14551       ELSEIF(N.GT.NS+2) THEN
14552         JR=3-JT
14553         DQ2(3)=Q2B
14554         DPC(1)=P(IS(1),4)
14555         DPC(2)=P(IS(2),4)
14556         DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14557         DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14558         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14559         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14560         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14561         IKIN=0
14562         IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14563      &  1D-10*DPD(1)) IKIN=1
14564         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14565      &  (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14566         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14567      &  (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14568  
14569 C...Generate timelike parton shower (if required).
14570         IT=N
14571         DO 290 J=1,5
14572           K(IT,J)=0
14573           P(IT,J)=0D0
14574           V(IT,J)=0D0
14575   290   CONTINUE
14576 C...f -> f + g (gamma).
14577         IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14578           K(IT,2)=21
14579           IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14580 C...f -> g (gamma, W+-) + f.
14581         ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14582           K(IT,2)=KFLB
14583           IF(KFLS(JT+2).EQ.24) THEN
14584             K(IT,2)=-12
14585           ELSEIF(KFLS(JT+2).EQ.-24) THEN
14586             K(IT,2)=12
14587           ENDIF
14588 C...g (gamma) -> f + fbar, g + g.
14589         ELSE
14590           K(IT,2)=-KFLS(JT+2)
14591           IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14592         ENDIF
14593         K(IT,1)=3
14594         IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14595      &  IABS(K(IT,2)).EQ.22) K(IT,1)=1
14596         P(IT,5)=PYMASS(K(IT,2))
14597         IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14598         IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14599           MSTJ48=MSTJ(48)
14600           PARJ85=PARJ(85)
14601           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14602           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14603           IF(MSTP(63).EQ.1) THEN
14604             Q2TIM=DMSMA
14605           ELSEIF(MSTP(63).EQ.2) THEN
14606             Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14607           ELSE
14608             Q2TIM=DMSMA
14609             MSTJ(48)=1
14610             IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14611             IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14612      &      DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14613             PARJ(85)=SQRT(MAX(0D0,DPT2))*
14614      &      (1D0/P(IT,4)+1D0/P(IS(JT),4))
14615           ENDIF
14616 C...Only do timelike shower here if using PYSHOW
14617           IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14618             CALL PYSHOW(IT,0,SQRT(Q2TIM))
14619           ENDIF
14620           MSTJ(48)=MSTJ48
14621           PARJ(85)=PARJ85
14622           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14623         ENDIF
14624  
14625 C...Reconstruct kinematics of branching: timelike parton shower.
14626         DMS=P(IT,5)**2
14627         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14628         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14629      &  0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14630      &  (4D0*DSH*DPC(3)**2)
14631         IF(DPT2.LT.0D0) GOTO 100
14632         DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14633      &  DSHR)/DPC(3)-DPC(3)
14634         P(IT,1)=SQRT(DPT2)
14635         P(IT,3)=DPB(1)*(-1)**(JT+1)
14636         P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14637         IF(N.GE.IT+1) THEN
14638           DPB(1)=SQRT(DPB(1)**2+DPT2)
14639           DPB(2)=SQRT(DPB(1)**2+DMS)
14640           DPB(3)=P(IT+1,3)
14641           DPB(4)=SQRT(DPB(3)**2+DMS)
14642           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14643      &    DPB(1))
14644           CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14645           THE=PYANGL(P(IT,3),P(IT,1))
14646           CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14647         ENDIF
14648  
14649 C...Reconstruct kinematics of branching: spacelike parton.
14650         DO 300 J=1,5
14651           K(N+1,J)=0
14652           P(N+1,J)=0D0
14653           V(N+1,J)=0D0
14654   300   CONTINUE
14655         K(N+1,1)=14
14656         K(N+1,2)=KFLB
14657         P(N+1,1)=P(IT,1)
14658         P(N+1,3)=P(IT,3)+P(IS(JT),3)
14659         P(N+1,4)=P(IT,4)+P(IS(JT),4)
14660         P(N+1,5)=-SQRT(DQ2(3))
14661         MCT(N+1,1)=0
14662         MCT(N+1,2)=0
14663  
14664 C...Define colour flow of branching.
14665         K(IS(JT),3)=N+1
14666         K(IT,3)=N+1
14667         IM1=N+1
14668         IM2=N+1
14669 C...f -> f + gamma (Z, W).
14670         IF(IABS(K(IT,2)).GE.22) THEN
14671           K(IT,1)=1
14672           ID1=IS(JT)
14673           ID2=IS(JT)
14674 C...f -> gamma (Z, W) + f.
14675         ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14676           ID1=IT
14677           ID2=IT
14678 C...gamma -> q + qbar, g + g.
14679         ELSEIF(K(N+1,2).EQ.22) THEN
14680           ID1=IS(JT)
14681           ID2=IT
14682           IM1=ID2
14683           IM2=ID1
14684 C...q -> q + g.
14685         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14686           ID1=IT
14687           ID2=IS(JT)
14688 C...q -> g + q.
14689         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14690           ID1=IS(JT)
14691           ID2=IT
14692 C...qbar -> qbar + g.
14693         ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14694           ID1=IS(JT)
14695           ID2=IT
14696 C...qbar -> g + qbar.
14697         ELSEIF(K(N+1,2).LT.0) THEN
14698           ID1=IT
14699           ID2=IS(JT)
14700 C...g -> g + g; g -> q + qbar.
14701         ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14702           ID1=IS(JT)
14703           ID2=IT
14704         ELSE
14705           ID1=IT
14706           ID2=IS(JT)
14707         ENDIF
14708         IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14709         IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14710         K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14711         K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14712         IF(ID1.NE.ID2) THEN
14713           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14714           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14715         ENDIF
14716         N=N+1
14717         IF(K(IT,1).EQ.1) THEN
14718           K(IT,4)=0
14719           K(IT,5)=0
14720         ENDIF
14721  
14722 C...Boost to new CM-frame.
14723         DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14724         DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14725         IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14726         CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14727         IR=N+(JT-1)*(IS(1)-N)
14728         CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14729      &  0D0,0D0,0D0)
14730  
14731 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14732         IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14733           NPART=NPART+1
14734           IPART(NPART)=IT
14735           PTPART(NPART)=SQRT(PARP(71)*DPT2)
14736         ENDIF
14737 
14738 C...Global statistics.
14739         MINT(352)=MINT(352)+1
14740         VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14741         IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14742 
14743       ENDIF
14744  
14745 C...Update kinematics variables.
14746       IS(JT)=N
14747       DQ2(JT)=Q2B
14748       IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14749       DSH=DSHZ
14750  
14751 C...Save quantities; loop back.
14752       Q2S(JT)=Q2B
14753       DPHI(JT)=PHIBR
14754       MCESV(JT)=MCE
14755       IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14756      &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14757         KFLS(JT+2)=KFLS(JT)
14758         KFLS(JT)=KFLA
14759         XS(JT)=XA
14760         ZS(JT)=Z
14761         DO 310 KFL=-25,25
14762           XFS(JT,KFL)=XFA(KFL)
14763   310   CONTINUE
14764         TEVCSV(JT)=TEVCB
14765         TEVESV(JT)=TEVEB
14766       ELSE
14767         MORE(JT)=0
14768         IF(JT.EQ.1) IPU1=N
14769         IF(JT.EQ.2) IPU2=N
14770       ENDIF
14771       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14772         CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14773         IF(MSTU(21).GE.1) N=NS
14774         IF(MSTU(21).GE.1) RETURN
14775       ENDIF
14776       IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14777  
14778 C...Boost hard scattering partons to frame of shower initiators.
14779       DO 320 J=1,3
14780         ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14781   320 CONTINUE
14782       K(N+2,1)=1
14783       DO 330 J=1,5
14784         P(N+2,J)=P(NS+1,J)
14785   330 CONTINUE
14786       CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14787       ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14788       ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14789       IMIN=MINT(83)+5
14790       IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14791       CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14792       CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14793  
14794 C...Store user information. Reset Lambda value.
14795       IF(MINT(31).LE.1) THEN
14796         K(IPU1,3)=MINT(83)+3
14797         K(IPU2,3)=MINT(83)+4
14798       ELSE
14799         K(IPU1,3)=MINT(83)+1
14800         K(IPU2,3)=MINT(83)+2
14801       ENDIF
14802       DO 340 JT=1,2
14803         MINT(12+JT)=KFLS(JT)
14804         VINT(140+JT)=XS(JT)
14805         IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14806         IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14807   340 CONTINUE
14808       PARU(112)=ALAMS
14809  
14810       RETURN
14811       END
14812 
14813 C*********************************************************************
14814  
14815 C...PYPTIS
14816 C...Generates pT-ordered spacelike initial-state parton showers and
14817 C...trial joinings.
14818 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14819 C...         interaction initiators at PT2NOW.
14820 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14821 C...         MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14822 C...         Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14823 C...         is below PT2CUT.
14824 C...         (Also generate test joinings if MSTP(96)=1.)
14825 C...MODE= 1: Accept stored shower branching. Update event record etc.
14826 C...PT2NOW : Starting (max) PT2 scale for evolution.
14827 C...PT2CUT : Lower limit for evolution.
14828 C...PT2    : Result of evolution. Generated PT2 for trial emission.
14829 C...IFAIL  : Status return code. IFAIL=0 when all is well.
14830  
14831       SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14832  
14833 C...Double precision and integer declarations.
14834       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14835       IMPLICIT INTEGER(I-N)
14836       INTEGER PYK,PYCHGE,PYCOMP
14837 C...Parameter statement for maximum size of showers.
14838       PARAMETER (MAXNUR=1000)
14839 C...Commonblocks.
14840       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14841       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14842       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14843       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14844       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14845       COMMON/PYINT1/MINT(400),VINT(400)
14846       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14847       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14848      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14849      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
14850       COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14851      &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14852       COMMON/PYCTAG/NCT,MCT(4000,2)
14853       COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14854       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14855      &     /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14856 C...Local variables
14857       DIMENSION ZSAV(2,240),PT2SAV(2,240),
14858      &     XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14859      &     WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14860      &     WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14861       SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14862      &     RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14863 C...For check on excessive weights.
14864       CHARACTER CHWT*12
14865  
14866 C...Only give errors for very large weights, otherwise just warnings
14867       DATA WTEMAX /1.5D0/
14868 C...Only give errors for large pT, otherwise just warnings
14869       DATA PTEMAX /5D0/
14870  
14871       IFAIL=-1
14872  
14873 C----------------------------------------------------------------------
14874 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14875 C...starting from the hardest interaction initiators.
14876       IF (MODE.EQ.-1) THEN
14877 C...Set hard scattering SHAT.
14878         SHTNOW(1)=VINT(44)
14879 C...Mass thresholds and Lambda for QCD evolution.
14880         AEM2PI=PARU(101)/PARU(2)
14881         RMB=PMAS(5,1)
14882         RMC=PMAS(4,1)
14883         ALAM4=PARP(61)
14884         IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14885         IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14886         ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14887         ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14888 C...Optionally use Lambda_MC = Lambda_CMW 
14889         IF (MSTP(64).EQ.3) THEN
14890           ALAM5 = ALAM5 * 1.569 
14891           ALAM4 = ALAM4 * 1.618 
14892           ALAM3 = ALAM3 * 1.661 
14893         ENDIF
14894         RMB2=RMB**2
14895         RMC2=RMC**2
14896 C...Massive quark forced creation threshold (in M**2).
14897         TMIN=1.01D0
14898 C...Set upper limit for X (ensures some X left for beam remnant).
14899         XMXC=1D0-2D0*PARP(111)/VINT(1)
14900  
14901         IF (MSTP(61).GE.1) THEN
14902 C...Initial values: flavours, momenta, virtualities.
14903           DO 100 JS=1,2
14904             NISGEN(JS,1)=0
14905  
14906 C...Special kinematics check for c/b quarks (that g -> c cbar or
14907 C...b bbar kinematically possible).
14908             KFLB=K(IMI(JS,1,1),2)
14909             KFLCB=IABS(KFLB)
14910             IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14911 C...Check PT2MAX > mQ^2
14912               IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14913                 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14914      &               'No Q creation possible.')
14915                 MINT(51)=1
14916                 RETURN
14917               ELSE
14918 C...Check for physical z values (m == MQ / sqrt(s))
14919 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14920                 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14921                 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14922                 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14923                   CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14924      &                 'Q creation.')
14925                   MINT(51)=1
14926                   RETURN
14927                 ENDIF
14928               ENDIF
14929             ENDIF
14930   100     CONTINUE
14931         ENDIF
14932  
14933         MINT(354)=0
14934 C...Zero joining array
14935         DO 110 MJ=1,240
14936           MJOIND(1,MJ)=0
14937           MJOIND(2,MJ)=0
14938   110   CONTINUE
14939  
14940 C----------------------------------------------------------------------
14941 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14942 C...MINT(30). Store if emission PT2 scale is largest so far.
14943 C...Also generate test joinings if MSTP(96)=1.
14944       ELSEIF(MODE.EQ.0) THEN
14945         IFAIL=-1
14946         MECOR=0
14947         ISUB=MINT(1)
14948         JS=MINT(30)
14949 C...No shower for structureless beam
14950         IF (MINT(44+JS).EQ.1) RETURN
14951         MI=MINT(36)
14952         SHAT=VINT(44)
14953 C...Absolute shower max scale = VINT(56)
14954         IF (MSTP(67).NE.0) THEN
14955           PT2 = MIN(PT2NOW,VINT(56))
14956         ELSE
14957 C...For MSTP(67)=0, adjust starting scale by PARP(67)
14958           PT2=MIN(PT2NOW,PARP(67)*VINT(56))
14959         ENDIF
14960         IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14961 C...Define for which processes ME corrections have been implemented.
14962         IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14963           IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14964      &         .142.OR.ISUB.EQ.144) MECOR=1
14965           IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14966           IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14967 C...Calculate preweighting factor for ME-corrected processes.
14968           IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14969         ENDIF
14970 C...Basic info on daughter for which to find mother.
14971         KFLB=K(IMI(JS,MI,1),2)
14972         KFLBA=IABS(KFLB)
14973 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14974 C...second companion.
14975         KSVCB=MAX(-1,IMI(JS,MI,2))
14976 C...Treat "first" companion of a pair like an ordinary sea quark
14977 C...(except that creation diagram is not allowed)
14978         IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14979 C...X (rescaled to [0,1])
14980         XB=XMI(JS,MI)/VINT(142+JS)
14981 C...Massive quarks (use physical masses.)
14982         RMQ2=0D0
14983         MQMASS=0
14984         IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14985           RMQ2=RMC2
14986           IF (KFLBA.EQ.5) RMQ2=RMB2
14987 C...Special threshold treatment for non-photon beams
14988           IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14989 C...Check that not below mass threshold.
14990           IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
14991             CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
14992      &        'No Q creation possible.')
14993             MINT(51)=1
14994 C...Special return code if failing before any evolution at all: bad event
14995             IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
14996             RETURN
14997           ENDIF
14998 
14999         ENDIF
15000  
15001 C...Flags for parton distribution calls.
15002         MINT(105)=MINT(102+JS)
15003         MINT(109)=MINT(106+JS)
15004         VINT(120)=VINT(2+JS)
15005  
15006 C...Calculate initial parton distribution weights.
15007         IF(XB.GE.XMXC) THEN
15008           RETURN
15009         ELSEIF(MQMASS.EQ.0) THEN
15010           CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15011         ELSE
15012 C...Initialize massive quark PT2 dependent pdf underestimate.
15013           PT20=PT2
15014           CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
15015 C.!.Tentative treatment of massive valence quarks.
15016           XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
15017           XG0=XFB(21)
15018           TPM0=LOG(PT20/RMQ2)
15019           WPDF0=TPM0*XG0/XQ0
15020         ENDIF
15021         IF (KFLBA.LE.6) THEN
15022 C...For quarks, only include respective sea, val, or cmp part.
15023           IF (KSVCB.LE.0) THEN
15024             XFB(KFLB)=XPSVC(KFLB,KSVCB)
15025           ELSE
15026 C...Find companion's companion
15027             MISEA=0
15028   120       MISEA=MISEA+1
15029             IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
15030             XS=XMI(JS,MISEA)
15031             XREM=VINT(142+JS)
15032             YS=XS/(XREM+XS)
15033 C...Momentum fraction of the companion quark.
15034 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
15035             YB=XB*(1D0-YS)
15036             XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15037           ENDIF
15038         ENDIF
15039  
15040 C...Determine overestimated z range: switch at c and b masses.
15041   130   IF (PT2.GT.TMIN*RMB2) THEN
15042           IZRG=3
15043           PT2MNE=MAX(TMIN*RMB2,PT2CUT)
15044           B0=23D0/6D0
15045           ALAM2=ALAM5**2
15046         ELSEIF(PT2.GT.TMIN*RMC2) THEN
15047           IZRG=2
15048           PT2MNE=MAX(TMIN*RMC2,PT2CUT)
15049           B0=25D0/6D0
15050           ALAM2=ALAM4**2
15051         ELSE
15052           IZRG=1
15053           PT2MNE=PT2CUT
15054           B0=27D0/6D0
15055           ALAM2=ALAM3**2
15056         ENDIF
15057 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
15058         ALAM2=ALAM2/PARP(64)
15059 C...Overestimated ZMAX:
15060         IF (MQMASS.EQ.0) THEN
15061 C...Massless
15062           ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
15063      &         /PT2MNE)-1D0)
15064         ELSE
15065 C...Massive (limit for bremsstrahlung diagram > creation)
15066           FMQ=SQRT(RMQ2/SHTNOW(MI))
15067           ZMAX=1D0/(1D0+FMQ)
15068         ENDIF
15069         ZMIN=XB/XMXC
15070  
15071 C...If kinematically impossible then do not evolve.
15072         IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
15073  
15074 C...Reset Altarelli-Parisi and PDF weights.
15075         DO 140 KFL=-5,5
15076           WTAP(KFL)=0D0
15077           WTPDF(KFL)=0D0
15078   140   CONTINUE
15079         WTAP(21)=0D0
15080         WTPDF(21)=0D0
15081 C...Zero joining weights and compute X(partner) and X(mother) values.
15082         NJN=0
15083         IF (MSTP(96).NE.0) THEN
15084           DO 150 MJ=1,MINT(31)
15085             WTAPJ(MJ)=0D0
15086             WTPDFJ(MJ)=0D0
15087             X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
15088             Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
15089      &           +XMI(JS,MI))
15090   150     CONTINUE
15091         ENDIF
15092  
15093 C...Approximate Altarelli-Parisi weights (integrated AP dz).
15094 C...q -> q, g -> q or q -> q + gamma (already set which).
15095         IF(KFLBA.LE.5) THEN
15096 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
15097           IF (KSVCB.LT.0) THEN
15098             WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15099           ELSE
15100             RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
15101             RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
15102             WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
15103           ENDIF
15104           WTAP(21)=0.5D0*(ZMAX-ZMIN)
15105           WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15106           IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
15107           IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15108             WTAP(KFLB)=WTFF*WTAP(KFLB)
15109             WTAP(21)=WTGF*WTAP(21)
15110             WTAPE=WTFF*WTAPE
15111           ENDIF
15112           IF(MSTP(61).EQ.1) WTAPE=0D0
15113           IF (KSVCB.GE.1) THEN
15114 C...Kill normal creation but add joining diagrams for cmp quark.
15115             WTAP(21)=0D0
15116             IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
15117               CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
15118      &             " quark here. Not handled yet, giving up!")
15119               PT2=0D0
15120               MINT(51)=1
15121               RETURN
15122             ENDIF
15123 C...Check for possible joinings
15124             IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
15125 C...Find companion's companion.
15126               MJ=0
15127   160         MJ=MJ+1
15128               IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
15129               IF (MJOIND(JS,MJ).EQ.0) THEN
15130                 Y(MI)=YB+YS
15131                 Z=YB/Y(MI)
15132                 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
15133                 IF (WTAPJ(MJ).GT.1D-6) THEN
15134                   NJN=1
15135                 ELSE
15136                   WTAPJ(MJ)=0D0
15137                 ENDIF
15138               ENDIF
15139 C...Add trial gluon joinings.
15140               DO 170 MJ=1,MINT(31)
15141                 KFLC=K(IMI(JS,MJ,1),2)
15142                 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
15143                 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15144                 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15145                 IF (WTAPJ(MJ).GT.1D-6) THEN
15146                   NJN=NJN+1
15147                 ELSE
15148                   WTAPJ(MJ)=0D0
15149                 ENDIF
15150   170         CONTINUE
15151             ENDIF
15152           ELSEIF (IMI(JS,MI,2).GE.0) THEN
15153 C...Kill creation diagram for val quarks and sea quarks with companions.
15154             WTAP(21)=0D0
15155           ELSEIF (MQMASS.EQ.0) THEN
15156 C...Extra safety factor for massless sea quark creation.
15157             WTAP(21)=WTAP(21)*1.25D0
15158           ENDIF
15159  
15160 C...  q -> g, g -> g.
15161         ELSEIF(KFLB.EQ.21) THEN
15162 C...Here we decide later whether a quark picked up is valence or
15163 C...sea, so we maintain the extra factor sqrt(z) since we deal
15164 C...with the *sum* of sea and valence in this context.
15165           WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
15166 C...new: do not allow backwards evol to pick up heavy flavour.
15167           DO 180 KFL=1,MIN(3,MSTP(58))
15168             WTAP(KFL)=WTAPQ
15169             WTAP(-KFL)=WTAPQ
15170   180     CONTINUE
15171           WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
15172           IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15173             WTAPQ=WTFG*WTAPQ
15174             WTAP(21)=WTGG*WTAP(21)
15175           ENDIF
15176 C...Check for possible joinings (companions handled separately above)
15177           IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
15178      &         THEN
15179             DO 190 MJ=1,MINT(31)
15180               IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
15181               KSVCC=IMI(JS,MJ,2)
15182               IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15183               IF (KSVCC.GE.1) GOTO 190
15184               KFLC=K(IMI(JS,MJ,1),2)
15185 C...Only try g -> g + g once.
15186               IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
15187               Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15188               IF (KFLC.EQ.21) THEN
15189                 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15190               ELSE
15191                 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
15192               ENDIF
15193               IF (WTAPJ(MJ).GT.1D-6) THEN
15194                 NJN=NJN+1
15195               ELSE
15196                 WTAPJ(MJ)=0D0
15197               ENDIF
15198   190       CONTINUE
15199           ENDIF
15200         ENDIF
15201  
15202 C...Initialize massive quark evolution
15203         IF (MQMASS.NE.0) THEN
15204           RML=(RMQ2+VINT(18))/ALAM2
15205           TML=LOG(RML)
15206           TPL=LOG((PT2+VINT(18))/ALAM2)
15207           TPM=LOG((PT2+VINT(18))/RMQ2)
15208           WN=WTAP(21)*WPDF0/B0
15209         ENDIF
15210  
15211  
15212 C...Loopback point for iteration
15213         NTRY=0
15214         NTHRES=0
15215   200   NTRY=NTRY+1
15216         IF(NTRY.GT.500) THEN
15217           CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
15218           MINT(51)=1
15219           RETURN
15220         ENDIF
15221  
15222 C...  Calculate PDF weights and sum for evolution rate.
15223         WTSUM=0D0
15224         XFBO=MAX(1D-10,XFB(KFLB))
15225         DO 210 KFL=-5,5
15226           WTPDF(KFL)=XFB(KFL)/XFBO
15227           WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
15228   210   CONTINUE
15229 C...Only add gluon mother diagram for massless KFLB.
15230         IF(MQMASS.EQ.0) THEN
15231           WTPDF(21)=XFB(21)/XFBO
15232           WTSUM=WTSUM+WTAP(21)*WTPDF(21)
15233         ENDIF
15234         WTSUM=MAX(0.0001D0,WTSUM)
15235         WTSUMS=WTSUM
15236 C...Add joining diagrams where applicable.
15237         WTJOIN=0D0
15238         IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15239           DO 220 MJ=1,MINT(31)
15240             IF (WTAPJ(MJ).LT.1D-3) GOTO 220
15241             WTPDFJ(MJ)=1D0/XFBO
15242 C...x and x*pdf (+ sea/val) for parton C.
15243             KFLC=K(IMI(JS,MJ,1),2)
15244             KFLCA=IABS(KFLC)
15245             KSVCC=MAX(-1,IMI(JS,MJ,2))
15246             IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15247             MINT(30)=JS
15248             MINT(36)=MJ
15249             CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15250             MINT(36)=MI
15251             IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
15252               XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15253             ELSEIF (KSVCC.GE.1) THEN
15254               print*, 'error! parton C is companion!'
15255             ENDIF
15256             WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
15257 C...x and x*pdf (+ sea/val) for parton A.
15258             KFLA=21
15259             KSVCA=0
15260             IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15261               KFLA=KFLB
15262               KSVCA=KSVCB
15263             ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15264               KFLA=KFLC
15265               KSVCA=KSVCC
15266             ENDIF
15267             MINT(30)=JS
15268             IF (KSVCA.LE.0) THEN
15269 C...Consider C the "evolved" parton if B is gluon. Val/sea
15270 C...counting will then be done correctly in PYPDFU.
15271               IF (KFLBA.EQ.21) MINT(36)=MJ
15272               CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15273               MINT(36)=MI
15274               IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15275             ELSE
15276 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15277               XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15278             ENDIF
15279             WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15280             WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15281   220     CONTINUE
15282         ENDIF
15283  
15284 C...Pick normal pT2 (in overestimated z range).
15285   230   PT2OLD=PT2
15286         WTSUM=WTSUMS
15287         PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15288         KFLC=21
15289  
15290 C...Evolve q -> q gamma separately, pick it if larger pT.
15291         IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN
15292           PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15293           IF(PT2QED.GT.PT2) THEN
15294             PT2=PT2QED
15295             KFLC=22
15296             KFLA=KFLB
15297           ENDIF
15298         ENDIF
15299  
15300 C...  Evolve massive quark creation separately.
15301         MCRQQ=0
15302         IF (MQMASS.NE.0) THEN
15303           PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15304      &         -VINT(18)
15305 C...If massive quark also on opposite side, ensure sufficient remaining 
15306 C...phase space also for creation of that quark
15307           TMINQQ = TMIN
15308           KFLOPP = K(IMI(3-JS,MI,1),2)
15309           IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
15310 C...Ensure mininimum PT2CR and force creation near threshold.
15311           IF (PT2CR.LT.TMINQQ*RMQ2) THEN
15312             NTHRES=NTHRES+1
15313             IF (NTHRES.GT.50) THEN
15314               CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15315      &             'massive quark creation. Gave up trying.')
15316               MINT(51)=1
15317 C...Special return code if failing before any evolution at all: bad event
15318               IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15319               RETURN
15320             ENDIF
15321             PT2=0D0
15322             PT2CR=TMINQQ*RMQ2
15323 C...Signal that massive quark creation is being forced
15324             MCRQQ=2
15325           ENDIF
15326 C...  Select largest PT2 (brems or creation):
15327           IF (PT2CR.GT.PT2) THEN
15328             MCRQQ=MAX(MCRQQ,1)
15329             WTSUM=0D0
15330             PT2=PT2CR
15331             KFLA=21
15332           ELSE
15333             MCRQQ=0
15334             KFLA=KFLB
15335           ENDIF
15336 C...  Compute logarithms for this PT2
15337           TPL=LOG((PT2+VINT(18))/ALAM2)
15338           TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15339           WTCRQQ=TPM/LOG(PT2/RMQ2)
15340         ENDIF
15341  
15342 C...Evolve joining separately
15343         MJOIN=0
15344         IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15345           PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15346      &         -VINT(18)
15347           IF (PT2JN.GE.PT2) THEN
15348             MJOIN=1
15349             PT2=PT2JN
15350           ENDIF
15351         ENDIF
15352  
15353 C...Loopback if crossed c/b mass thresholds.
15354         IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15355           PT2=RMB2
15356          GOTO 130
15357         ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15358           PT2=RMC2
15359           GOTO 130
15360         ENDIF
15361  
15362 C...Speed up shower. Skip if higher-PT acceptable branching
15363 C...already found somewhere else.
15364 C...Also finish if below lower cutoff.
15365         IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN
15366 
15367 C...Select parton A flavour (massive Q handled above.)
15368         IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15369           WTRAN=PYR(0)*WTSUM
15370           KFLA=-6
15371   240     KFLA=KFLA+1
15372           WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15373           IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15374           IF(KFLA.EQ.6) KFLA=21
15375         ELSEIF (MJOIN.EQ.1) THEN
15376 C...Tentative joining accept/reject.
15377           WTRAN=PYR(0)*WTJOIN
15378           MJ=0
15379   250     MJ=MJ+1
15380           WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15381           IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15382           IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15383             CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15384      &           ' Rejected.')
15385             GOTO 230
15386           ENDIF
15387 C...x*pdf (+ sea/val) at new pT2 for parton B.
15388           IF (KSVCB.LE.0) THEN
15389             MINT(30)=JS
15390             CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15391             IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15392           ELSE
15393 C...Companion distributions do not evolve.
15394             XFB(KFLB)=XFBO
15395           ENDIF
15396           WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15397           KFLC=K(IMI(JS,MJ,1),2)
15398           KFLCA=IABS(KFLC)
15399           KSVCC=MAX(-1,IMI(JS,MJ,2))
15400           IF (KSVCB.GE.1) KSVCC=-1
15401 C...x*pdf (+ sea/val) at new pT2 for parton C.
15402           MINT(30)=JS
15403           MINT(36)=MJ
15404           CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15405           MINT(36)=MI
15406           IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15407           WTVETO=WTVETO/XFJ(KFLC)
15408 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15409           KFLA=21
15410           KSVCA=0
15411           IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15412             KFLA=KFLB
15413             KSVCA=KSVCB
15414           ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15415             KFLA=KFLC
15416             KSVCA=KSVCC
15417           ENDIF
15418           IF (KSVCA.LE.0) THEN
15419             MINT(30)=JS
15420             IF (KFLB.EQ.21) MINT(36)=MJ
15421             CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15422             MINT(36)=MI
15423             IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15424           ELSE
15425             XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15426           ENDIF
15427 C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
15428 C...picked up by ISR (necessary since intertwining not implemented)
15429 C...Here simply kill backwards-evolution probability.
15430           IF (KFLB.EQ.21.AND.(IABS(KFLA).EQ.4.OR.IABS(KFLA).EQ.5)) THEN
15431             IF (KSVCA.GE.1) WTVETO = 0D0
15432           ENDIF
15433           WTVETO=WTVETO*XFJ(KFLA)
15434 C...Monte Carlo veto to accept trial joining
15435           IF (WTVETO.LT.PYR(0)) GOTO 200
15436 C...If accept, save PT2 of this joining.
15437           IF (PT2.GT.PT2MX) THEN
15438             PT2MX=PT2
15439             JSMX=2+JS
15440             MJN1MX=MJ
15441             MJN2MX=MI
15442             WTAPJ(MJ)=0D0
15443             NJN=0
15444           ENDIF
15445 C...Exit and continue evolution.
15446           GOTO 390
15447         ENDIF
15448         KFLAA=IABS(KFLA)
15449  
15450 C...Choose z value (still in overestimated range) and corrective weight.
15451 C...Unphysical z will be rejected below when Q2 has is computed.
15452         WTZ=0D0
15453  
15454 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15455 C...q -> q + g or q -> q + gamma (already set which).
15456         IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15457           IF (KSVCB.LT.0) THEN
15458             Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15459           ELSE
15460             ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15461             Z=((1-ZFAC)/(1+ZFAC))**2
15462           ENDIF
15463           WTZ=0.5D0*(1D0+Z**2)
15464 C...Massive weight correction.
15465           IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15466 C...Valence quark weight correction (extra sqrt)
15467           IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15468  
15469 C...q -> g + q.
15470 C...NB: MQ>0 not yet implemented. Forced absent above.
15471         ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15472           KFLC=KFLA
15473           Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15474           WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15475  
15476 C...g -> q + qbar.
15477         ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15478           KFLC=-KFLB
15479           Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15480           WTZ=Z**2+(1D0-Z)**2
15481 C...Massive correction
15482           IF (MQMASS.NE.0) THEN
15483             WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15484 C...Extra safety margin for light sea quark creation
15485           ELSEIF (KSVCB.LT.0) THEN
15486             WTZ=WTZ/1.25D0
15487           ENDIF
15488  
15489 C...g -> g + g.
15490         ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15491           KFLC=21
15492           Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15493      &         (ZMAX*(1D0-ZMIN)))**PYR(0))
15494           WTZ=(1D0-Z*(1D0-Z))**2
15495         ENDIF
15496  
15497 C...Derive Q2 from pT2.
15498         Q2B=PT2/(1D0-Z)
15499         IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15500  
15501 C...Loopback if outside allowed z range for given pT2.
15502         RM2C=PYMASS(KFLC)**2
15503         PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15504         IF (PT2ADJ.LT.1D-6) GOTO 230
15505  
15506 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15507 C...No modification for very first emission if using ME correction
15508         MSTP67 = MSTP(67)
15509         IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15510           MSTP67 = 0
15511         ENDIF
15512  
15513 C...For 1st branching, limit phase space by s-hat with color-partner
15514 C...(prevent infinite loop by limiting number of NTRY)
15515         IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0.AND.NTRY.LE.200) THEN
15516           MSIDE=1
15517           IDIP=IMI(JS,MI,1)
15518 C...Use anticolor tag for antiquark, or for gluon half the time
15519           IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.
15520      &         (KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15521 C...Tag
15522           MCTAG=MCT(IDIP,MSIDE)
15523 C...Default is to set up phase space using the opposite incoming parton
15524           JDIP=IMI(3-JS,MI,1)
15525           NDIP=0
15526 
15527 C...Alternatively, look for final-state color partner (pick last if several)
15528           DO 260 IFS=1,NPART
15529             MCJ = MCT(IPART(IFS),MSIDE)
15530             IF (MCJ.NE.MCTAG) GOTO 260
15531 C...Pick last matching final-state partner if several
15532 C...(if no matching final-state partner, defaults back to annihilation)
15533             KSJ = K(IPART(IFS),1)
15534             IF (KSJ.GE.1.AND.KSJ.LT.10) THEN
15535               JDIP=IPART(IFS)
15536               NDIP=NDIP+1
15537             ENDIF
15538   260     CONTINUE
15539 
15540 C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
15541 C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
15542           SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2
15543      &        -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2))
15544 
15545           IF (MSTP67.EQ.1) THEN
15546 C...1 Option to completely kill radiation above s_dip * PARP(67)
15547             IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230
15548           ELSE IF (MSTP67.EQ.2) THEN
15549 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15550 C...  (-> improved power showers?)
15551             IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15552           ENDIF
15553           
15554 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15555         ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15556           IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15557      &         GOTO 230
15558         ENDIF
15559  
15560 C...Select phi angle of branching at random.
15561         PHI=PARU(2)*PYR(0)
15562  
15563 C...Matrix-element corrections for some processes.
15564         IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15565           IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15566             CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15567             WTZ=WTZ*WTME/WTFF
15568           ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15569             CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15570             WTZ=WTZ*WTME/WTGF
15571           ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15572             CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15573             WTZ=WTZ*WTME/WTFG
15574           ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15575             CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15576             WTZ=WTZ*WTME/WTGG
15577           ENDIF
15578         ENDIF
15579  
15580 C...Parton distributions at new pT2 but old x.
15581         MINT(30)=JS
15582         CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15583 C...Treat val and cmp separately
15584         IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15585         IF (KSVCB.GE.1)
15586      &       XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15587         XFBN=XFN(KFLB)
15588         IF(XFBN.LT.1D-20) THEN
15589           IF(KFLA.EQ.KFLB) THEN
15590             WTAP(KFLB)=0D0
15591             GOTO 200
15592           ELSE
15593             XFBN=1D-10
15594             XFN(KFLB)=XFBN
15595           ENDIF
15596         ENDIF
15597         DO 270 KFL=-5,5
15598           XFB(KFL)=XFN(KFL)
15599   270   CONTINUE
15600         XFB(21)=XFN(21)
15601  
15602 C...Parton distributions at new pT2 and new x.
15603         XA=XB/Z
15604         MINT(30)=JS
15605         CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15606         IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15607 C...q -> q + g: only consider respective sea, val, or cmp content.
15608           IF (KSVCB.LE.0) THEN
15609             XFA(KFLA)=XPSVC(KFLA,KSVCB)
15610           ELSE
15611             YA=XA*(1D0-YS)
15612             XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15613           ENDIF
15614         ENDIF
15615         XFAN=XFA(KFLA)
15616         IF(XFAN.LT.1D-20) THEN
15617           GOTO 200
15618         ENDIF
15619  
15620 C...If weighting fails continue evolution.
15621         WTTOT=0D0
15622         IF (MCRQQ.EQ.0) THEN
15623           WTPDFA=1D0/WTPDF(KFLA)
15624           WTTOT=WTZ*XFAN/XFBN*WTPDFA
15625         ELSEIF(MCRQQ.EQ.1) THEN
15626           WTPDFA=TPM/WPDF0
15627           WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15628           XBEST=TPM/TPM0*XQ0
15629         ELSEIF(MCRQQ.EQ.2) THEN
15630 C...Force massive quark creation.
15631           WTTOT=1D0
15632         ENDIF
15633  
15634 C...Loop back if trial emission fails.
15635         IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15636         WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15637         IF(WTTOT.LT.0D0) THEN
15638           WRITE(CHWT,'(1P,E12.4)') WTTOT
15639           CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15640         ELSEIF(WTTOT.GT.WTACC) THEN
15641           WRITE(CHWT,'(1P,E12.4)') WTTOT
15642           IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15643 C...Too high weight: write out as error, but do not update error counter
15644             IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15645             CALL PYERRM(19,
15646      &         '(PYPTIS:) Weight '//CHWT//' above unity')
15647             IF (PT2.GT.PTEMAX) PTEMAX=PT2
15648             IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15649           ELSE
15650             CALL PYERRM(9,
15651      &         '(PYPTIS:) Weight '//CHWT//' above unity')
15652           ENDIF
15653 C...Useful for debugging but commented out for distribution:
15654 C          print*, 'JS, MI',JS, MI
15655 C          print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15656 C          print*, 'A -> B C',KFLA, KFLB, KFLC
15657 C          XFAO=XFBO/WTPDFA
15658 C          print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15659         ENDIF
15660  
15661 C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks 
15662 C...simultaneously reached their creation thresholds) 
15663         IF (ABS(PT2-PT2MX).LT.0.001) THEN
15664           IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
15665         ENDIF
15666 
15667 C...Save acceptable branching.
15668         IF(PT2.GT.PT2MX) THEN
15669           MIMX=MINT(36)
15670           JSMX=JS
15671           PT2MX=PT2
15672           KFLAMX=KFLA
15673           KFLCMX=KFLC
15674           RM2CMX=RM2C
15675           Q2BMX=Q2B
15676           ZMX=Z
15677           PT2AMX=PT2ADJ
15678           PHIMX=PHI
15679         ENDIF
15680  
15681 C----------------------------------------------------------------------
15682 C...MODE= 1: Accept stored shower branching. Update event record etc.
15683       ELSEIF (MODE.EQ.1) THEN
15684         MI=MIMX
15685         JS=JSMX
15686         SHAT=SHTNOW(MI)
15687         SIDE=3D0-2D0*JS
15688 C...Shift down rest of event record to make room for insertion.
15689         IT=IMISEP(MI)+1
15690         IM=IT+1
15691         IS=IMI(JS,MI,1)
15692         DO 290 I=N,IT,-1
15693           IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15694           KT1=K(I,4)/MSTU(5)**2
15695           KT2=K(I,5)/MSTU(5)**2
15696           ID1=MOD(K(I,4),MSTU(5))
15697           ID2=MOD(K(I,5),MSTU(5))
15698           IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15699           IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15700           IF (ID1.GE.IT) ID1=ID1+2
15701           IF (ID2.GE.IT) ID2=ID2+2
15702           IF (IM1.GE.IT) IM1=IM1+2
15703           IF (IM2.GE.IT) IM2=IM2+2
15704           K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15705           K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15706           DO 280 IX=1,5
15707             K(I+2,IX)=K(I,IX)
15708             P(I+2,IX)=P(I,IX)
15709             V(I+2,IX)=V(I,IX)
15710   280     CONTINUE
15711           MCT(I+2,1)=MCT(I,1)
15712           MCT(I+2,2)=MCT(I,2)
15713   290   CONTINUE
15714         N=N+2
15715 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15716         DO 300 JI=1,MINT(31)
15717           IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15718           IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15719           IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15720           IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15721           IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15722 C...Also update companion pointers to the present mother.
15723           IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15724   300   CONTINUE
15725         DO 310 IFS=1,NPART
15726           IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15727   310   CONTINUE
15728 C...Zero entries dedicated for new timelike and mother partons.
15729         DO 330 I=IT,IT+1
15730           DO 320 J=1,5
15731             K(I,J)=0
15732             P(I,J)=0D0
15733             V(I,J)=0D0
15734   320     CONTINUE
15735           MCT(I,1)=0
15736           MCT(I,2)=0
15737   330   CONTINUE
15738  
15739 C...Define timelike and new mother partons. History.
15740         K(IT,1)=3
15741         K(IT,2)=KFLCMX
15742         K(IM,1)=14
15743         K(IM,2)=KFLAMX
15744         K(IS,3)=IM
15745         K(IT,3)=IM
15746 C...Set mother origin = side.
15747         K(IM,3)=MINT(83)+JS+2
15748         IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15749  
15750 C...Define colour flow of branching.
15751         IM1=IM
15752         IM2=IM
15753 C...q -> q + gamma.
15754         IF(K(IT,2).EQ.22) THEN
15755           K(IT,1)=1
15756           ID1=IS
15757           ID2=IS
15758 C...q -> q + g.
15759         ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15760           ID1=IT
15761           ID2=IS
15762 C...q -> g + q.
15763         ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15764           ID1=IS
15765           ID2=IT
15766 C...qbar -> qbar + g.
15767         ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15768           ID1=IS
15769           ID2=IT
15770 C...qbar -> g + qbar.
15771         ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15772           ID1=IT
15773           ID2=IS
15774 C...g -> g + g; g -> q + qbar..
15775         ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15776           ID1=IS
15777           ID2=IT
15778         ELSE
15779           ID1=IT
15780           ID2=IS
15781         ENDIF
15782         IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15783         IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15784         K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15785         K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15786         IF(ID1.NE.ID2) THEN
15787           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15788           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15789         ENDIF
15790         IF(K(IT,1).EQ.1) THEN
15791           K(IT,4)=0
15792           K(IT,5)=0
15793         ENDIF
15794 C...Update IMI and colour tag arrays.
15795         IMI(JS,MI,1)=IM
15796         DO 340 MC=1,2
15797           MCT(IT,MC)=0
15798           MCT(IM,MC)=0
15799   340   CONTINUE
15800         DO 350 JCS=4,5
15801           KCS=JCS
15802 C...If mother flag not yet set for spacelike parton, trace it.
15803           IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15804           IF(MINT(51).NE.0) RETURN
15805   350   CONTINUE
15806         DO 360 JCS=4,5
15807           KCS=JCS
15808 C...If mother flag not yet set for timelike parton, trace it.
15809           IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15810           IF(MINT(51).NE.0) RETURN
15811   360   CONTINUE
15812  
15813 C...Boost recoiling parton to compensate for Q2 scale.
15814         BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15815      &  (1D0+(1D0+Q2BMX/SHAT)**2)
15816         IR=IMI(3-JS,MI,1)
15817         CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15818  
15819 C...Define system to be rotated and boosted
15820 C...(not including the 2 just added partons)
15821 C...(but including the docu lines for first interaction)
15822         IMIN=IMISEP(MI-1)+1
15823         IF (MI.EQ.1) IMIN=MINT(83)+5
15824         IMAX=IMISEP(MI)-2
15825  
15826 C...Rotate back system in phi to compensate for subsequent rotation.
15827         CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15828  
15829 C...Define kinematics of new partons in old frame.
15830         IMAX=IMISEP(MI)
15831         P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15832         P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15833      &       +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15834         P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15835         P(IT,1)=P(IM,1)
15836         P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15837         P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15838         P(IT,5)=SQRT(RM2CMX)
15839  
15840 C...Update internal line, now spacelike
15841         P(IS,1)=P(IM,1)-P(IT,1)
15842         P(IS,2)=P(IM,2)-P(IT,2)
15843         P(IS,3)=P(IM,3)-P(IT,3)
15844         P(IS,4)=P(IM,4)-P(IT,4)
15845         P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15846 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15847         IF (P(IS,5).LT.0D0) THEN
15848           P(IS,5)=-SQRT(ABS(P(IS,5)))
15849         ELSE
15850           P(IS,5)=SQRT(P(IS,5))
15851         ENDIF
15852  
15853 C...Boost entire system and rotate to new frame.
15854 C...(including docu lines)
15855         BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15856         BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15857         IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15858           CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15859           MINT(51)=1
15860           IFAIL=-1
15861           RETURN
15862         ENDIF
15863         CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15864         I1=IMI(1,MI,1)
15865         THETA=PYANGL(P(I1,3),P(I1,1))
15866         CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15867  
15868 C...Global statistics.
15869         MINT(352)=MINT(352)+1
15870         VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15871         IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15872  
15873 C...Add parton with relevant pT scale for timelike shower.
15874         IF (K(IT,2).NE.22) THEN
15875           NPART=NPART+1
15876           IPART(NPART)=IT
15877           PTPART(NPART)=SQRT(PT2AMX)
15878         ENDIF
15879  
15880 C...Update saved variables.
15881         SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15882         NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15883         XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15884         PT2SAV(JSMX,MIMX)=PT2MX
15885         ZSAV(JS,MIMX)=ZMX
15886  
15887         KSA=IABS(K(IS,2))
15888         KMA=IABS(K(IM,2))
15889         IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15890 C...Gluon reconstructs to quark.
15891 C...Decide whether newly created quark is valence or sea:
15892           MINT(30)=JS
15893           CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15894           IF(MINT(51).NE.0) RETURN
15895         ENDIF
15896         IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15897 C...Quark reconstructs to gluon.
15898 C...Now some guy may have lost his companion. Check.
15899           ICMP=IMI(JS,MI,2)
15900           IF (ICMP.GT.0) THEN
15901             CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15902      &           //' away. Cannot handle that yet. Giving up.')
15903             MINT(51)=1
15904             RETURN
15905           ELSEIF(ICMP.LT.0) THEN
15906 C...A sea quark with companion still in BR was reconstructed to a gluon.
15907 C...Companion should now be removed from the beam remnant.
15908 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15909             ICMP=-ICMP
15910             IFL=-K(IS,2)
15911             DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15912               XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15913               DO 370 JI=1,MINT(31)
15914                 KMI=-IMI(JS,JI,2)
15915                 JFL=-K(IMI(JS,JI,1),2)
15916                 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15917      &               ,2)+1
15918   370         CONTINUE
15919   380       CONTINUE
15920             NVC(JS,IFL)=NVC(JS,IFL)-1
15921           ENDIF
15922 C...Set gluon IMI(JS,MI,2) = 0.
15923           IMI(JS,MI,2)=0
15924         ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15925 C...Quark reconstructing to quark. If sea with companion still in BR
15926 C...then update associated x value.
15927 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15928           IF (IMI(JS,MI,2).LT.0) THEN
15929             ICMP=-IMI(JS,MI,2)
15930             IFL=-K(IS,2)
15931             XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15932           ENDIF
15933         ENDIF
15934  
15935       ENDIF
15936  
15937 C...If reached this point, normal exit.
15938   390 IFAIL=0
15939  
15940       RETURN
15941       END
15942  
15943 C*********************************************************************
15944  
15945 C...PYMEMX
15946 C...Generates maximum ME weight in some initial-state showers.
15947 C...Inparameter MECOR: kind of hard scattering process
15948 C...Outparameter WTFF: maximum weight for fermion -> fermion
15949 C...             WTGF: maximum weight for gluon/photon -> fermion
15950 C...             WTFG: maximum weight for fermion -> gluon/photon
15951 C...             WTGG: maximum weight for gluon -> gluon
15952  
15953       SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15954  
15955 C...Double precision and integer declarations.
15956       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15957       IMPLICIT INTEGER(I-N)
15958       INTEGER PYK,PYCHGE,PYCOMP
15959 C...Commonblocks.
15960       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15961       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15962       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15963       COMMON/PYINT1/MINT(400),VINT(400)
15964       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15965       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15966  
15967 C...Default maximum weight.
15968       WTFF=1D0
15969       WTGF=1D0
15970       WTFG=1D0
15971       WTGG=1D0
15972  
15973 C...Select maximum weight by process.
15974       IF(MECOR.EQ.1) THEN
15975         WTFF=1D0
15976         WTGF=3D0
15977       ELSEIF(MECOR.EQ.2) THEN
15978         WTFG=1D0
15979         WTGG=1D0
15980       ENDIF
15981  
15982       RETURN
15983       END
15984  
15985 C*********************************************************************
15986  
15987 C...PYMEWT
15988 C...Calculates actual ME weight in some initial-state showers.
15989 C...Inparameter MECOR: kind of hard scattering process
15990 C...            IFLCB: flavour combination of branching,
15991 C...                   1 for fermion -> fermion,
15992 C...                   2 for gluon/photon -> fermion
15993 C...                   3 for fermion -> gluon/photon,
15994 C...                   4 for gluon -> gluon
15995 C...            Q2:    Q2 value of shower branching
15996 C...            Z:     Z value of branching
15997 C...In+outparameter PHIBR: azimuthal angle of branching
15998 C...Outparameter WTME: actual ME weight
15999  
16000       SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
16001  
16002 C...Double precision and integer declarations.
16003       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16004       IMPLICIT INTEGER(I-N)
16005       INTEGER PYK,PYCHGE,PYCOMP
16006 C...Commonblocks.
16007       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16008       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16009       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16010       COMMON/PYINT1/MINT(400),VINT(400)
16011       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16012       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
16013  
16014 C...Default output.
16015       WTME=1D0
16016  
16017 C...Define kinematics of shower branching in Mandelstam variables.
16018       SQM=VINT(44)
16019       SH=SQM/Z
16020       TH=-Q2
16021       UH=Q2-SQM*(1D0-Z)/Z
16022  
16023 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
16024       IF(MECOR.EQ.1) THEN
16025         IF(IFLCB.EQ.1) THEN
16026           WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
16027         ELSEIF(IFLCB.EQ.2) THEN
16028           WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
16029         ENDIF
16030  
16031 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
16032       ELSEIF(MECOR.EQ.2) THEN
16033         IF(IFLCB.EQ.3) THEN
16034           WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
16035         ELSEIF(IFLCB.EQ.4) THEN
16036           WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
16037         ENDIF
16038 
16039 C...Matrix-element corrections for q + qbar -> Higgs (h0)
16040       ELSEIF(MECOR.EQ.3) THEN
16041         IF(IFLCB.EQ.2) THEN
16042           WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
16043      1      (SH**2+2D0*SQM*(SQM-SH))
16044         ENDIF
16045       ENDIF
16046  
16047       RETURN
16048       END
16049  
16050 C*********************************************************************
16051  
16052 C...PYPTMI
16053 C...Handles the generation of additional interactions in the new
16054 C...multiple interactions framework.
16055 C...MODE=-1 : Initalize MI from scratch.
16056 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
16057 C...         Sudakov for PT2, abort if below PT2CUT.
16058 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
16059 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
16060 C...PT2NOW  : Starting (max) PT2 scale for evolution.
16061 C...PT2CUT  : Lower limit for evolution.
16062 C...PT2     : Result of evolution. Generated PT2 for trial interaction.
16063 C...IFAIL   : Status return code.
16064 C...         = 0: All is well.
16065 C...         < 0: Phase space exhausted, generation to be terminated.
16066 C...         > 0: Additional interaction vetoed, but continue evolution.
16067  
16068       SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
16069 C...Double precision and integer declarations.
16070       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16071       IMPLICIT INTEGER(I-N)
16072       INTEGER PYK,PYCHGE,PYCOMP
16073 C...Parameter statement for maximum size of showers.
16074       PARAMETER (MAXNUR=1000)
16075 C...Commonblocks.
16076       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16077       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16078       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16079       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16080       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16081       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16082       COMMON/PYINT1/MINT(400),VINT(400)
16083       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16084       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
16085       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16086       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
16087       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
16088      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
16089      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
16090       COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
16091      &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
16092       COMMON/PYCTAG/NCT,MCT(4000,2)
16093 C...Local arrays and saved variables.
16094       DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
16095  
16096       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
16097      &     /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
16098      &     /PYISMX/,/PYCTAG/
16099       SAVE NCHN,XT2FAC,SIGS
16100  
16101       IFAIL=0
16102 C...Set MI subprocess = QCD 2 -> 2.
16103       ISUB=96
16104  
16105 C----------------------------------------------------------------------
16106 C...MODE=-1: Initialize from scratch
16107       IF (MODE.EQ.-1) THEN
16108 C...Initialize PT2 array.
16109         PT2MI(1)=VINT(54)
16110 C...Initialize list of incoming beams and partons from two sides.
16111         DO 110 JS=1,2
16112           DO 100 MI=1,240
16113             IMI(JS,MI,1)=0
16114             IMI(JS,MI,2)=0
16115   100     CONTINUE
16116           NMI(JS)=1
16117           IMI(JS,1,1)=MINT(84)+JS
16118           IMI(JS,1,2)=0
16119           XMI(JS,1)=VINT(40+JS)
16120 C...Rescale x values to fractions of photon energy.
16121           IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
16122 C...Hard reset: hard interaction initiators motherless by definition.
16123           K(MINT(84)+JS,3)=2+JS
16124           K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
16125           K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
16126   110   CONTINUE
16127         IMISEP(0)=MINT(84)
16128         IMISEP(1)=N
16129         IF (MOD(MSTP(81),10).GE.1) THEN
16130           IF(MSTP(82).LE.1) THEN
16131             SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
16132      &           ,5))
16133             IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
16134      &           VINT(317)/(VINT(318)*VINT(320))
16135             XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
16136           ELSE
16137             XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
16138      &           MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
16139           ENDIF
16140         ENDIF
16141 C...Zero entries relating to scatterings beyond the first.
16142         DO 120 MI=2,240
16143           IMI(1,MI,1)=0
16144           IMI(2,MI,1)=0
16145           IMI(1,MI,2)=0
16146           IMI(2,MI,2)=0
16147           IMISEP(MI)=IMISEP(1)
16148           PT2MI(MI)=0D0
16149           XMI(1,MI)=0D0
16150           XMI(2,MI)=0D0
16151   120   CONTINUE
16152 C...Initialize factors for PDF reshaping.
16153         DO 140 JS=1,2
16154           KFBEAM(JS)=MINT(10+JS)
16155           IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
16156           KFABM=IABS(KFBEAM(JS))
16157           KFSBM=ISIGN(1,KFBEAM(JS))
16158  
16159 C...Zero flavour content of incoming beam particle.
16160           KFIVAL(JS,1)=0
16161           KFIVAL(JS,2)=0
16162           KFIVAL(JS,3)=0
16163 C...  Flavour content of baryon.
16164           IF(KFABM.GT.1000) THEN
16165             KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
16166             KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
16167             KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
16168 C...  Flavour content of pi+-, K+-.
16169           ELSEIF(KFABM.EQ.211) THEN
16170             KFIVAL(JS,1)=KFSBM*2
16171             KFIVAL(JS,2)=-KFSBM
16172           ELSEIF(KFABM.EQ.321) THEN
16173             KFIVAL(JS,1)=-KFSBM*3
16174             KFIVAL(JS,2)=KFSBM*2
16175 C...  Flavour content of pi0, gamma, K0S, K0L not defined yet.
16176           ENDIF
16177  
16178 C...Zero initial valence and companion content.
16179           DO 130 IFL=-6,6
16180             NVC(JS,IFL)=0
16181   130     CONTINUE
16182   140   CONTINUE
16183 C...Set up colour line tags starting from hard interaction initiators.
16184         NCT=0
16185 C...Reset colour tag array and colour processing flags.
16186         DO 150 I=IMISEP(0)+1,N
16187           MCT(I,1)=0
16188           MCT(I,2)=0
16189           K(I,4)=MOD(K(I,4),MSTU(5)**2)
16190           K(I,5)=MOD(K(I,5),MSTU(5)**2)
16191   150   CONTINUE
16192 C...  Consider each side in turn.
16193         DO 170 JS=1,2
16194           I1=IMI(JS,1,1)
16195           I2=IMI(3-JS,1,1)
16196           DO 160 JCS=4,5
16197             IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16198      &           GOTO 160
16199             IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
16200             KCS=JCS
16201             CALL PYCTTR(I1,KCS,I2)
16202             IF(MINT(51).NE.0) RETURN
16203   160     CONTINUE
16204   170   CONTINUE
16205  
16206 C...Range checking for companion quark pdf large-x param.
16207         IF (MSTP(87).LT.0) THEN
16208           CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16209      &         ' MSTP(87)=0')
16210           MSTP(87)=0
16211         ELSEIF (MSTP(87).GT.4) THEN
16212           CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16213      &         ' MSTP(87)=4')
16214           MSTP(87)=4
16215         ENDIF
16216  
16217 C----------------------------------------------------------------------
16218 C...MODE=0: Generate trial interaction. Return codes:
16219 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
16220 C...IFAIL = 0: Additional interaction generated at PT2.
16221 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
16222       ELSEIF (MODE.EQ.0) THEN
16223 C...Abolute MI max scale = VINT(62)
16224         XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
16225   180   IF(MSTP(82).LE.1) THEN
16226           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
16227           IF(XT2.LT.VINT(149)) IFAIL=-2
16228         ELSE
16229           IF(XT2.LE.0.01001D0*VINT(149)) THEN
16230             IFAIL=-3
16231           ELSE
16232             XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
16233      &           LOG(PYR(0)))-VINT(149)
16234           ENDIF
16235         ENDIF
16236 C...Also exit if below lower limit or if higher trial branching
16237 C...already found.
16238         PT2=0.25D0*VINT(2)*XT2
16239         IF (PT2.LE.PT2CUT) IFAIL=-4
16240         IF (PT2.LE.PT2MX) IFAIL=-5
16241         IF (IFAIL.NE.0) THEN
16242           PT2=0D0
16243           RETURN
16244         ENDIF
16245         IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
16246         VINT(25)=4D0*PT2/VINT(2)
16247         XT2=VINT(25)
16248  
16249 C...Choose tau and y*. Calculate cos(theta-hat).
16250         IF(PYR(0).LE.COEF(ISUB,1)) THEN
16251           TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
16252           TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
16253         ELSE
16254           TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
16255         ENDIF
16256         VINT(21)=TAU
16257 C...New: require shat > 1.
16258         IF(TAU*VINT(2).LT.1D0) GOTO 180
16259         CALL PYKLIM(2)
16260         RYST=PYR(0)
16261         MYST=1
16262         IF(RYST.GT.COEF(ISUB,8)) MYST=2
16263         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
16264         CALL PYKMAP(2,MYST,PYR(0))
16265         VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
16266  
16267 C...Check that x not used up. Accept or reject kinematical variables.
16268         X1M=SQRT(TAU)*EXP(VINT(22))
16269         X2M=SQRT(TAU)*EXP(-VINT(22))
16270         IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16271         VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16272         NCHN=0
16273         CALL PYSIGH(NCHN,SIGS)
16274         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16275         IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16276         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16277  
16278 C...Save if highest PT so far.
16279         IF (PT2.GT.PT2MX) THEN
16280           JSMX=0
16281           MIMX=MINT(31)+1
16282           PT2MX=PT2
16283         ENDIF
16284  
16285 C----------------------------------------------------------------------
16286 C...MODE=1: Generate and save accepted scattering.
16287       ELSEIF (MODE.EQ.1) THEN
16288         PT2=PT2NOW
16289 C...Reset K, P, V, and MCT vectors.
16290         DO 200 I=N+1,N+4
16291           DO 190 J=1,5
16292             K(I,J)=0
16293             P(I,J)=0D0
16294             V(I,J)=0D0
16295   190     CONTINUE
16296           MCT(I,1)=0
16297           MCT(I,2)=0
16298   200   CONTINUE
16299  
16300         NTRY=0
16301 C...Choose flavour of reacting partons (and subprocess).
16302   210   NTRY=NTRY+1
16303         IF (NTRY.GT.50) THEN
16304           CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16305      &               //'interaction. Giving up!')
16306           MINT(51)=1
16307           RETURN
16308         ENDIF
16309         RSIGS=SIGS*PYR(0)
16310         DO 220 ICHN=1,NCHN
16311           KFL1=ISIG(ICHN,1)
16312           KFL2=ISIG(ICHN,2)
16313           ICONMI=ISIG(ICHN,3)
16314           RSIGS=RSIGS-SIGH(ICHN)
16315           IF(RSIGS.LE.0D0) GOTO 230
16316   220   CONTINUE
16317  
16318 C...Reassign to appropriate process codes.
16319   230   ISUBMI=ICONMI/10
16320         ICONMI=MOD(ICONMI,10)
16321  
16322 C...Choose new quark flavour for annihilation graphs
16323         IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16324           SH=VINT(21)*VINT(2)
16325           CALL PYWIDT(21,SH,WDTP,WDTE)
16326   240     RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16327           DO 250 I=1,MDCY(21,3)
16328             KFLF=KFDP(I+MDCY(21,2)-1,1)
16329             RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16330             IF(RKFL.LE.0D0) GOTO 260
16331   250     CONTINUE
16332   260     IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16333             IF(KFLF.GE.4) GOTO 240
16334           ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16335             KFLF=4
16336             ICONMI=ICONMI-2
16337           ELSEIF(ISUBMI.EQ.53) THEN
16338             KFLF=5
16339             ICONMI=ICONMI-4
16340           ENDIF
16341         ENDIF
16342  
16343 C...Final state flavours and colour flow: default values
16344         JS=1
16345         KFL3=KFL1
16346         KFL4=KFL2
16347         KCC=20
16348         KCS=ISIGN(1,KFL1)
16349  
16350         IF(ISUBMI.EQ.11) THEN
16351 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16352           KCC=ICONMI
16353           IF(KFL1*KFL2.LT.0) KCC=KCC+2
16354  
16355         ELSEIF(ISUBMI.EQ.12) THEN
16356 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16357           KFL3=ISIGN(KFLF,KFL1)
16358           KFL4=-KFL3
16359           KCC=4
16360  
16361         ELSEIF(ISUBMI.EQ.13) THEN
16362 C...f + fbar -> g + g; th arbitrary
16363           KFL3=21
16364           KFL4=21
16365           KCC=ICONMI+4
16366  
16367         ELSEIF(ISUBMI.EQ.28) THEN
16368 C...f + g -> f + g; th = (p(f)-p(f))**2
16369           IF(KFL1.EQ.21) JS=2
16370           KCC=ICONMI+6
16371           IF(KFL1.EQ.21) KCC=KCC+2
16372           IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16373           IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16374  
16375         ELSEIF(ISUBMI.EQ.53) THEN
16376 C...g + g -> f + fbar; th arbitrary
16377           KCS=(-1)**INT(1.5D0+PYR(0))
16378           KFL3=ISIGN(KFLF,KCS)
16379           KFL4=-KFL3
16380           KCC=ICONMI+10
16381  
16382         ELSEIF(ISUBMI.EQ.68) THEN
16383 C...g + g -> g + g; th arbitrary
16384           KCC=ICONMI+12
16385           KCS=(-1)**INT(1.5D0+PYR(0))
16386         ENDIF
16387  
16388 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16389         IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16390      &       .OR.IABS(KFL4).EQ.5) THEN
16391           RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16392           IF (PT2.LE.1.05*RMMAX2) THEN
16393             IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16394      &           //' too close to threshold (2nd try).')
16395             GOTO 210
16396           ENDIF
16397         ENDIF
16398  
16399 C...Store flavours of scattering.
16400         MINT(13)=KFL1
16401         MINT(14)=KFL2
16402         MINT(15)=KFL1
16403         MINT(16)=KFL2
16404         MINT(21)=KFL3
16405         MINT(22)=KFL4
16406  
16407 C...Set flavours and mothers of scattering partons.
16408         K(N+1,1)=14
16409         K(N+2,1)=14
16410         K(N+3,1)=3
16411         K(N+4,1)=3
16412         K(N+1,2)=KFL1
16413         K(N+2,2)=KFL2
16414         K(N+3,2)=KFL3
16415         K(N+4,2)=KFL4
16416         K(N+1,3)=MINT(83)+1
16417         K(N+2,3)=MINT(83)+2
16418         K(N+3,3)=N+1
16419         K(N+4,3)=N+2
16420  
16421 C...Store colour connection indices.
16422         DO 270 J=1,2
16423           JC=J
16424           IF(KCS.EQ.-1) JC=3-J
16425           IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16426           IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16427           IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16428           IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16429   270   CONTINUE
16430  
16431 C...Store incoming and outgoing partons in their CM-frame.
16432         SHR=SQRT(VINT(21))*VINT(1)
16433         P(N+1,3)=0.5D0*SHR
16434         P(N+1,4)=0.5D0*SHR
16435         P(N+2,3)=-0.5D0*SHR
16436         P(N+2,4)=0.5D0*SHR
16437         P(N+3,5)=PYMASS(K(N+3,2))
16438         P(N+4,5)=PYMASS(K(N+4,2))
16439         IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16440           IFAIL=1
16441           RETURN
16442         ENDIF
16443         P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16444         P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16445         P(N+4,4)=SHR-P(N+3,4)
16446         P(N+4,3)=-P(N+3,3)
16447  
16448 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16449         PHI=PARU(2)*PYR(0)
16450         CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16451  
16452 C...Global statistics.
16453         MINT(351)=MINT(351)+1
16454         VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16455         IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16456  
16457 C...Keep track of loose colour ends and information on scattering.
16458         MINT(31)=MINT(31)+1
16459         MINT(36)=MINT(31)
16460         PT2MI(MINT(36))=PT2
16461         IMISEP(MINT(31))=N+4
16462         DO 280 JS=1,2
16463           IMI(JS,MINT(31),1)=N+JS
16464           IMI(JS,MINT(31),2)=0
16465           XMI(JS,MINT(31))=VINT(40+JS)
16466           NMI(JS)=NMI(JS)+1
16467 C...Update cumulative counters
16468           VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16469           VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16470   280   CONTINUE
16471  
16472 C...Add to list of final state partons
16473         IPART(NPART+1)=N+3
16474         IPART(NPART+2)=N+4
16475         PTPART(NPART+1)=SQRT(PT2)
16476         PTPART(NPART+2)=SQRT(PT2)
16477         NPART=NPART+2
16478  
16479 C...Initialize ISR
16480         NISGEN(1,MINT(31))=0
16481         NISGEN(2,MINT(31))=0
16482  
16483 C...Update ER
16484         N=N+4
16485         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16486           CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16487           MINT(51)=1
16488           RETURN
16489         ENDIF
16490  
16491 C...Finally, assign colour tags to new partons
16492         DO 300 JS=1,2
16493           I1=IMI(JS,MINT(31),1)
16494           I2=IMI(3-JS,MINT(31),1)
16495           DO 290 JCS=4,5
16496             IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16497      &           GOTO 290
16498             IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16499             KCS=JCS
16500             CALL PYCTTR(I1,KCS,I2)
16501             IF(MINT(51).NE.0) RETURN
16502   290     CONTINUE
16503   300   CONTINUE
16504  
16505 C----------------------------------------------------------------------
16506 C...MODE=2: Decide whether quarks in last scattering were valence,
16507 C...companion, or sea.
16508       ELSEIF (MODE.EQ.2) THEN
16509         JS=MINT(30)
16510         MI=MINT(36)
16511         PT2=PT2NOW
16512         KFSBM=ISIGN(1,MINT(10+JS))
16513         IFL=K(IMI(JS,MI,1),2)
16514         IMI(JS,MI,2)=0
16515         IF (IABS(IFL).GE.6) THEN
16516           IF (IABS(IFL).EQ.6) THEN
16517             CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16518           ENDIF
16519           RETURN
16520         ENDIF
16521 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16522 C...(Do not include the parton itself in the X rescaling.)
16523         X=XMI(JS,MI)
16524         XRSC=X/(VINT(142+JS)+X)
16525 C...Note: XPSVC = x*pdf.
16526         MINT(30)=JS
16527         CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16528         SEA=XPSVC(IFL,-1)
16529         VAL=XPSVC(IFL,0) 
16530 C...Ensure that pdfs are positive definite   
16531         IF (SEA.LT.0D0) THEN
16532           CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16533           SEA=MAX(0D0,SEA)
16534         ELSEIF (VAL.LT.0D0) THEN
16535           CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16536           VAL=MAX(0D0,VAL)          
16537         ENDIF
16538         CMP=0D0
16539         DO 310 IVC=1,NVC(JS,IFL)
16540           CMP=CMP+XPSVC(IFL,IVC)
16541   310   CONTINUE
16542 C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
16543 C...picked up by MPI (necessary since intertwining not implemented)
16544 C...Here simply reclassify companions as ordinary SEA. Will give 
16545 C...additional spurious companions, but is simplest solution.
16546         IF (IABS(IFL).EQ.4.OR.IABS(IFL).EQ.5) THEN
16547           SEA = SEA + CMP
16548           CMP = 0D0
16549         ENDIF
16550  
16551         NTRY=0
16552 C...Decide (Extra factor x cancels in the dvision).
16553   320   RVCS=PYR(0)*(SEA+VAL+CMP)
16554         IVNOW=1
16555         NTRY=NTRY+1
16556   330   IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16557 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16558           IVNOW=0
16559           IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16560           IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16561           IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16562           IF(KFIVAL(JS,1).EQ.0) THEN
16563             IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16564             IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16565             IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16566      &           (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16567           ELSE
16568 C...Count down valence remaining. Do not count current scattering.
16569             DO 340 I1=1,NMI(JS)
16570               IF (I1.EQ.MINT(36)) GOTO 340
16571               IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16572      &             IVNOW=IVNOW-1
16573   340       CONTINUE
16574           ENDIF
16575           IF(IVNOW.EQ.0) GOTO 330
16576 C...Mark valence.
16577           IMI(JS,MI,2)=0
16578 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16579           IF(KFIVAL(JS,1).EQ.0) THEN
16580             IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16581               KFIVAL(JS,1)=IFL
16582               KFIVAL(JS,2)=-IFL
16583             ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16584               KFIVAL(JS,1)=IFL
16585               IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16586               IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16587             ENDIF
16588           ENDIF
16589  
16590         ELSEIF (RVCS.LE.VAL+SEA) THEN
16591 C...If sea, add opposite sign companion parton. Store X and I.
16592           NVC(JS,-IFL)=NVC(JS,-IFL)+1
16593           XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16594 C...Set pointer to companion
16595           IMI(JS,MI,2)=-NVC(JS,-IFL)
16596  
16597         ELSE
16598 C...If companion, check whether we've got any in the books
16599           IF (NVC(JS,IFL).EQ.0) THEN
16600             CMP=0D0
16601 C...Only report error first time for this event
16602             IF (NTRY.EQ.1) 
16603      &           CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16604 C...Try a few times
16605             IF (NTRY.LE.10) THEN
16606               GOTO 320
16607 C... But if it stil fails, abort this event
16608             ELSE
16609               MINT(51)=1
16610               RETURN
16611             ENDIF
16612           ENDIF
16613 C...If several possibilities, decide which one
16614           CMPSUM=VAL+SEA
16615           ISEL=0
16616   350     ISEL=ISEL+1
16617           CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16618           IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16619 C...Find original sea (anti-)quark. Do not consider current scattering.
16620           IASSOC=0
16621           DO 360 I1=1,NMI(JS)
16622             IF (I1.EQ.MINT(36)) GOTO 360
16623             IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16624             IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16625               IMI(JS,MI,2)=IMI(JS,I1,1)
16626               IMI(JS,I1,2)=IMI(JS,MI,1)
16627             ENDIF
16628   360     CONTINUE
16629 C...Mark companion "out-kicked".
16630           XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16631         ENDIF
16632  
16633       ENDIF
16634       RETURN
16635       END
16636  
16637 C*********************************************************************
16638  
16639 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16640 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16641 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16642 C...corresponds to an unrescaled range between 0 and 1-X.
16643  
16644       FUNCTION PYFCMP(XC,XS,NPOW)
16645       IMPLICIT NONE
16646       DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16647       INTEGER NPOW
16648  
16649       PYFCMP=0D0
16650 C...Parent gluon momentum fraction
16651       Y=XC+XS
16652       IF (Y.GE.1D0) RETURN
16653 C...Common factor (includes factor XC, since PYFCMP=x*f)
16654       FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16655 C...Store normalized companion x*f distribution.
16656       IF (NPOW.LE.0) THEN
16657         PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16658       ELSEIF (NPOW.EQ.1) THEN
16659         PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16660       ELSEIF (NPOW.EQ.2) THEN
16661         PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16662      &       +3D0*XS*(1D0+XS)*LOG(XS)))
16663       ELSEIF (NPOW.EQ.3) THEN
16664         PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16665      &       +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16666       ELSEIF (NPOW.GE.4) THEN
16667         PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16668      &       XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16669       ENDIF
16670       RETURN
16671       END
16672  
16673 C*********************************************************************
16674  
16675 C...PYPCMP: Auxiliary to PYPDFU.
16676 C...Giving the momentum integral of a companion quark, with its
16677 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16678 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16679  
16680       FUNCTION PYPCMP(XS,NPOW)
16681       IMPLICIT NONE
16682       DOUBLE PRECISION XS, PYPCMP
16683       INTEGER NPOW
16684       IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16685         PYPCMP=0D0
16686       ELSEIF (NPOW.LE.0) THEN
16687         PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16688         PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16689       ELSEIF (NPOW.EQ.1) THEN
16690         PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16691      &       /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16692       ELSEIF (NPOW.EQ.2) THEN
16693         PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16694      &       +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16695         PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16696      &       -3D0*XS*LOG(XS)*(1+XS)))
16697       ELSEIF (NPOW.EQ.3) THEN
16698         PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16699      &       -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16700         PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16701      &       +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16702       ELSE
16703         PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16704      &       *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16705         PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16706      &       -6D0*XS*LOG(XS)*(1D0+XS)))
16707       ENDIF
16708       RETURN
16709       END
16710  
16711 C*********************************************************************
16712  
16713 C...PYUPRE
16714 C...Rearranges contents of the HEPEUP commonblock so that
16715 C...mothers precede daughters and daughters of a decay are
16716 C...listed consecutively.
16717  
16718       SUBROUTINE PYUPRE
16719  
16720 C...Double precision and integer declarations.
16721       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16722       IMPLICIT INTEGER(I-N)
16723  
16724 C...User process event common block.
16725       INTEGER MAXNUP
16726       PARAMETER (MAXNUP=500)
16727       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16728       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16729       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16730      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16731      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16732       SAVE /HEPEUP/
16733  
16734 C...Local arrays.
16735       DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16736      &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16737      &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16738  
16739 C...Check whether a rearrangement is required.
16740       NEED=0
16741       DO 100 IUP=1,NUP
16742         IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16743   100 CONTINUE
16744       DO 110 IUP=2,NUP
16745         IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16746   110 CONTINUE
16747  
16748       IF(NEED.NE.0) THEN
16749 C...Find the new order that particles should have.
16750         NEWPOS(0)=0
16751         NNEW=0
16752         INEW=-1
16753   120   INEW=INEW+1
16754         DO 130 IUP=1,NUP
16755           IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16756             NNEW=NNEW+1
16757             NEWPOS(NNEW)=IUP
16758           ENDIF
16759   130   CONTINUE
16760         IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16761         IF(NNEW.NE.NUP) THEN
16762           CALL PYERRM(2,
16763      &    '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16764           RETURN
16765         ENDIF
16766  
16767 C...Copy old info into temporary storage.
16768         DO 150 I=1,NUP
16769           IDUPT(I)=IDUP(I)
16770           ISTUPT(I)=ISTUP(I)
16771           MOTUPT(1,I)=MOTHUP(1,I)
16772           MOTUPT(2,I)=MOTHUP(2,I)
16773           ICOUPT(1,I)=ICOLUP(1,I)
16774           ICOUPT(2,I)=ICOLUP(2,I)
16775           DO 140 J=1,5
16776             PUPT(J,I)=PUP(J,I)
16777   140     CONTINUE
16778           VTIUPT(I)=VTIMUP(I)
16779           SPIUPT(I)=SPINUP(I)
16780   150   CONTINUE
16781  
16782 C...Copy info back into HEPEUP in right order.
16783         DO 180 I=1,NUP
16784           IOLD=NEWPOS(I)
16785           IDUP(I)=IDUPT(IOLD)
16786           ISTUP(I)=ISTUPT(IOLD)
16787           MOTHUP(1,I)=0
16788           MOTHUP(2,I)=0
16789           DO 160 IMOT=1,I-1
16790             IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16791             IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16792   160     CONTINUE
16793           IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16794             MOTHSW=MOTHUP(1,I)
16795             MOTHUP(1,I)=MOTHUP(2,I)
16796             MOTHUP(2,I)=MOTHSW
16797           ENDIF
16798           ICOLUP(1,I)=ICOUPT(1,IOLD)
16799           ICOLUP(2,I)=ICOUPT(2,IOLD)
16800           DO 170 J=1,5
16801             PUP(J,I)=PUPT(J,IOLD)
16802   170     CONTINUE
16803           VTIMUP(I)=VTIUPT(IOLD)
16804           SPINUP(I)=SPIUPT(IOLD)
16805   180   CONTINUE
16806       ENDIF
16807  
16808 c...If incoming particles are massive recalculate to put them massless.
16809       IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16810         PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16811         PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16812         PUP(4,1)=0.5D0*PPLUS
16813         PUP(3,1)=PUP(4,1)
16814         PUP(5,1)=0D0
16815         PUP(4,2)=0.5D0*PMINUS
16816         PUP(3,2)=-PUP(4,2)
16817         PUP(5,2)=0D0
16818       ENDIF
16819  
16820       RETURN
16821       END
16822  
16823 C*********************************************************************
16824  
16825 C...PYADSH
16826 C...Administers the generation of successive final-state showers
16827 C...in external processes.
16828  
16829       SUBROUTINE PYADSH(NFIN)
16830  
16831 C...Double precision and integer declarations.
16832       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16833       IMPLICIT INTEGER(I-N)
16834       INTEGER PYK,PYCHGE,PYCOMP
16835 C...Parameter statement for maximum size of showers.
16836       PARAMETER (MAXNUR=1000)
16837 C...Commonblocks.
16838       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16839       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16840       COMMON/PYCTAG/NCT,MCT(4000,2)
16841       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16842       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16843       COMMON/PYINT1/MINT(400),VINT(400)
16844       SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16845 C...Local array.
16846       DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16847  
16848 C...Set primary vertex.
16849       DO 100 J=1,5
16850         V(MINT(83)+5,J)=0D0
16851         V(MINT(83)+6,J)=0D0
16852         V(MINT(84)+1,J)=0D0
16853         V(MINT(84)+2,J)=0D0
16854   100 CONTINUE
16855  
16856 C...Isolate systems of particles with the same mother.
16857       NSYS=0
16858       IMS=-1
16859       DO 140 I=MINT(84)+3,NFIN
16860         IM=K(I,3)
16861         IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16862         IF(IM.NE.IMS) THEN
16863           NSYS=NSYS+1
16864           IBEG(NSYS)=I
16865           IMS=IM
16866         ENDIF
16867  
16868 C...Set production vertices.
16869         IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16870      &  THEN
16871           DO 110 J=1,4
16872             V(I,J)=0D0
16873   110     CONTINUE
16874         ELSE
16875           DO 120 J=1,4
16876             V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16877   120     CONTINUE
16878         ENDIF
16879         IF(MSTP(125).GE.1) THEN
16880           IDOC=I-MSTP(126)+4
16881           DO 130 J=1,5
16882             V(IDOC,J)=V(I,J)
16883   130     CONTINUE
16884         ENDIF
16885   140 CONTINUE
16886  
16887 C...End loop over systems. Return if no showers to be performed.
16888       IBEG(NSYS+1)=NFIN+1
16889       IF(MSTP(71).LE.0) RETURN
16890  
16891 C...Loop through systems of particles; check that sensible size.
16892       DO 270 ISYS=1,NSYS
16893         NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16894         IF(MINT(35).LE.2) THEN
16895           IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16896             GOTO 270
16897           ELSEIF(NSIZ.LE.1) THEN
16898             CALL PYERRM(2,'(PYADSH:) only one particle in system')
16899             GOTO 270
16900           ELSEIF(NSIZ.GT.80) THEN
16901             CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16902             GOTO 270
16903           ENDIF
16904         ENDIF
16905  
16906 C...Save status codes and daughters of showering particles; reset them.
16907         DO 150 J=1,4
16908           PSUM(J)=0D0
16909   150   CONTINUE
16910         DO 170 II=1,NSIZ
16911           I=IBEG(ISYS)-1+II
16912           KSAV(II,1)=K(I,1)
16913           IF(K(I,1).GT.10) THEN
16914             K(I,1)=1
16915             IF(KSAV(II,1).EQ.14) K(I,1)=3
16916           ENDIF
16917           IF(KSAV(II,1).LE.10) THEN
16918           ELSEIF(K(I,1).EQ.1) THEN
16919             KSAV(II,4)=K(I,4)
16920             KSAV(II,5)=K(I,5)
16921             K(I,4)=0
16922             K(I,5)=0
16923           ELSE
16924             KSAV(II,4)=MOD(K(I,4),MSTU(5))
16925             KSAV(II,5)=MOD(K(I,5),MSTU(5))
16926             K(I,4)=K(I,4)-KSAV(II,4)
16927             K(I,5)=K(I,5)-KSAV(II,5)
16928           ENDIF
16929           DO 160 J=1,4
16930             PSUM(J)=PSUM(J)+P(I,J)
16931   160     CONTINUE
16932   170   CONTINUE
16933  
16934 C...Perform shower.
16935         QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16936      &  PSUM(3)**2))
16937         IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16938         NSAV=N
16939         IF(MINT(35).LE.2) THEN
16940           IF(NSIZ.EQ.2) THEN
16941             CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16942           ELSE
16943             CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16944           ENDIF
16945  
16946 C...For external processes, first call, also ISR partons radiate.
16947 C...Can use existing PYPART list, removing partons that radiate later.
16948         ELSEIF(ISYS.EQ.1) THEN
16949           NPARTN=0
16950           DO 175 II=1,NPART
16951             IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16952               NPARTN=NPARTN+1
16953               IPART(NPARTN)=IPART(II)
16954               PTPART(NPARTN)=PTPART(II)
16955             ENDIF
16956  175      CONTINUE
16957           NPART=NPARTN
16958           CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16959         ELSE
16960 C...For subsequent calls use the systems excluded above.
16961           NPART=NSIZ
16962           NPARTD=0
16963           DO 180 II=1,NSIZ
16964             I=IBEG(ISYS)-1+II
16965             IPART(II)=I
16966             PTPART(II)=0.5D0*QMAX
16967   180     CONTINUE
16968           CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16969         ENDIF
16970  
16971 C...Look up showered copies of original showering particles.
16972         DO 260 II=1,NSIZ
16973           I=IBEG(ISYS)-1+II
16974           IMV=I
16975 C...Particles without daughters need not be studied.
16976           IF(KSAV(II,1).LE.10) GOTO 260
16977           IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16978           ELSEIF(K(I,1).EQ.11) THEN
16979   190       IMV=MOD(K(IMV,4),MSTU(5))
16980             IF(K(IMV,1).EQ.11) GOTO 190
16981           ELSE
16982             KDA1=MOD(K(I,4),MSTU(5))
16983             IF(KDA1.GT.0) THEN
16984               IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16985             ENDIF
16986             KDA2=MOD(K(I,5),MSTU(5))
16987             IF(KDA2.GT.0) THEN
16988               IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16989             ENDIF
16990             DO 200 I3=I+1,N
16991               IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16992      &        THEN
16993                 IMV=I3
16994                 KDA1=MOD(K(I3,4),MSTU(5))
16995                 IF(KDA1.GT.0) THEN
16996                   IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16997                 ENDIF
16998                 KDA2=MOD(K(I3,5),MSTU(5))
16999                 IF(KDA2.GT.0) THEN
17000                   IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17001                 ENDIF
17002               ENDIF
17003   200       CONTINUE
17004           ENDIF
17005  
17006 C...Restore daughter info of original partons to showered copies.
17007           IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
17008           IF(KSAV(II,1).LE.10) THEN
17009           ELSEIF(K(I,1).EQ.1) THEN
17010             K(IMV,4)=KSAV(II,4)
17011             K(IMV,5)=KSAV(II,5)
17012           ELSE
17013             K(IMV,4)=K(IMV,4)+KSAV(II,4)
17014             K(IMV,5)=K(IMV,5)+KSAV(II,5)
17015           ENDIF
17016  
17017 C...Reset mother info of existing daughters to showered copies.
17018           DO 210 I3=IBEG(ISYS+1),NFIN
17019             IF(K(I3,3).EQ.I) K(I3,3)=IMV
17020             IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
17021               IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
17022               IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
17023             ENDIF
17024   210     CONTINUE
17025  
17026 C...Boost all original daughters to new frame of showered copy.
17027 C...Also update their colour tags.
17028           IF(IMV.NE.I) THEN
17029             DO 220 J=1,3
17030               BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
17031   220       CONTINUE
17032             FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
17033             DO 230 J=1,3
17034               BETA(J)=FAC*BETA(J)
17035   230       CONTINUE
17036             DO 250 I3=IBEG(ISYS+1),NFIN
17037               IMO=I3
17038   240         IMO=K(IMO,3)
17039               IF(MSTP(128).LE.0) THEN
17040                 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
17041                 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
17042      &          THEN
17043                   CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17044                   IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17045                   IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17046                 ENDIF
17047               ELSE
17048                 IF(IMO.EQ.IMV) THEN
17049                   CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17050                   IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17051                   IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17052                 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
17053                   GOTO 240
17054                 ENDIF
17055               ENDIF
17056   250       CONTINUE
17057           ENDIF
17058   260   CONTINUE
17059  
17060 C...End of loop over showering systems
17061   270 CONTINUE
17062  
17063       RETURN
17064       END
17065  
17066 C*********************************************************************
17067  
17068 C...PYVETO
17069 C...Interface to UPVETO, which allows user to veto event generation
17070 C...on the parton level, after parton showers but before multiple
17071 C...interactions, beam remnants and hadronization is added.
17072  
17073       SUBROUTINE PYVETO(IVETO)
17074  
17075 C...All real arithmetic in double precision.
17076       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17077 C...Three Pythia functions return integers, so need declaring.
17078       INTEGER PYK,PYCHGE,PYCOMP
17079  
17080 C...PYTHIA commonblocks.
17081       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17082       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17083       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17084       COMMON/PYINT1/MINT(400),VINT(400)
17085       SAVE /PYJETS/,/PYPARS/,/PYINT1/
17086 C...HEPEVT commonblock.
17087       PARAMETER (NMXHEP=4000)
17088       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17089      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
17090       DOUBLE PRECISION PHEP,VHEP
17091       SAVE /HEPEVT/
17092 C...Local array.
17093       DIMENSION IRESO(100)
17094  
17095 C...Define longitudinal boost from initiator rest frame to cm frame.
17096       GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
17097       GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
17098 
17099 C...Presentation is different if using pT-ordered shower
17100       IF(MINT(35).EQ.3) THEN
17101         GAMMA=1D0
17102         GABEZ=0D0
17103       ENDIF
17104 
17105 C... Reset counters.
17106       NEVHEP=0
17107       NHEP=0
17108       NRESO=0
17109       
17110 C...Oth pass: identify beam and incoming partons
17111       DO 140 I=MINT(83)+1,MINT(83)+6
17112         ISTORE=0
17113         IF(K(I,2).EQ.94) THEN
17114 
17115         ELSE
17116           NRESO=NRESO+1
17117           IRESO(NRESO)=I
17118           IMOTH=K(I,3)
17119         ENDIF
17120  140  CONTINUE
17121 
17122 C...First pass: identify final locations of resonances
17123 C...and of their daughters before showering.
17124       DO 150 I=MINT(84)+3,N
17125         ISTORE=0
17126         IMOTH=0
17127  
17128 C...Skip shower CM frame documentation lines.
17129         IF(K(I,2).EQ.94) THEN
17130  
17131 C...  Store a new intermediate product, when mother in documentation.
17132         ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
17133      &  K(I,3).LE.MINT(84)) THEN
17134           ISTORE=1
17135           NHEP=NHEP+1
17136           II=NHEP
17137           NRESO=NRESO+1
17138           IRESO(NRESO)=I
17139           IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
17140  
17141 C...  Store a new intermediate product, when mother in main section.
17142         ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
17143      &  K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
17144           ISTORE=1
17145           NHEP=NHEP+1
17146           II=NHEP
17147           NRESO=NRESO+1
17148           IRESO(NRESO)=I
17149           IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
17150         ENDIF
17151   
17152         IF(ISTORE.EQ.1) THEN
17153 C...Copy parton info, boosting momenta along z axis to cm frame.
17154           ISTHEP(II)=2
17155           IDHEP(II)=K(I,2)
17156           PHEP(1,II)=P(I,1)
17157           PHEP(2,II)=P(I,2)
17158           PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17159           PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17160           PHEP(5,II)=P(I,5)
17161 C...Store one mother. Rest of history and vertex info zeroed.
17162           JMOHEP(1,II)=IMOTH
17163           JMOHEP(2,II)=0
17164           JDAHEP(1,II)=0
17165           JDAHEP(2,II)=0
17166           VHEP(1,II)=0D0
17167           VHEP(2,II)=0D0
17168           VHEP(3,II)=0D0
17169           VHEP(4,II)=0D0
17170         ENDIF
17171  150  CONTINUE
17172 
17173 C...Second pass: identify current set of "final" partons.
17174       DO 200 I=MINT(84)+3,N
17175         ISTORE=0
17176         IMOTH=0
17177  
17178 C...Store a final parton.
17179         IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
17180           ISTORE=1
17181           NHEP=NHEP+1
17182           II=NHEP
17183 C..Trace it back through shower, to check if from documented particle.
17184           IHIST=I
17185           ISAVE=IHIST
17186   160     CONTINUE
17187           IF(IHIST.GT.MINT(84)) THEN
17188             IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
17189             DO 170 IRI=1,NRESO
17190               IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
17191   170       CONTINUE
17192             ISAVE=IHIST
17193             IHIST=K(IHIST,3)
17194             IF(IMOTH.EQ.0) GOTO 160
17195             IMOTH=MAX(0,IMOTH-6)
17196           ELSEIF(IHIST.LE.4) THEN
17197             IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
17198               ISTORE=0
17199               NHEP=NHEP-1
17200             ELSE
17201               IMOTH=0
17202             ENDIF
17203           ENDIF
17204         ENDIF
17205  
17206         IF(ISTORE.EQ.1) THEN
17207 C...Copy parton info, boosting momenta along z axis to cm frame.
17208           ISTHEP(II)=1
17209           IDHEP(II)=K(I,2)
17210           PHEP(1,II)=P(I,1)
17211           PHEP(2,II)=P(I,2)
17212           PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17213           PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17214           PHEP(5,II)=P(I,5)
17215 C...Store one mother. Rest of history and vertex info zeroed.
17216           JMOHEP(1,II)=IMOTH
17217           JMOHEP(2,II)=0
17218           JDAHEP(1,II)=0
17219           JDAHEP(2,II)=0
17220           VHEP(1,II)=0D0
17221           VHEP(2,II)=0D0
17222           VHEP(3,II)=0D0
17223           VHEP(4,II)=0D0
17224         ENDIF
17225   200 CONTINUE
17226 C...Call user-written routine to decide whether to keep events.
17227       CALL UPVETO(IVETO)
17228       RETURN
17229       END
17230 C*********************************************************************
17231  
17232 C...PYRESD
17233 C...Allows resonances to decay (including parton showers for hadronic
17234 C...channels).
17235  
17236       SUBROUTINE PYRESD(IRES)
17237  
17238 C...Double precision and integer declarations.
17239       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17240       IMPLICIT INTEGER(I-N)
17241       INTEGER PYK,PYCHGE,PYCOMP
17242 C...Parameter statement to help give large particle numbers.
17243       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
17244      &KEXCIT=4000000,KDIMEN=5000000)
17245 C...Parameter statement for maximum size of showers.
17246       PARAMETER (MAXNUR=1000)
17247 C...Commonblocks.
17248       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
17249       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17250       COMMON/PYCTAG/NCT,MCT(4000,2)
17251       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17252       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17253       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
17254       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17255       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17256       COMMON/PYINT1/MINT(400),VINT(400)
17257       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17258       COMMON/PYINT4/MWID(500),WIDS(500,5)
17259       COMMON/PYPUED/IUED(0:99),RUED(0:99)
17260       SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
17261      &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
17262 C...Local arrays and complex and character variables.
17263       DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
17264      &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6),
17265      &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
17266      &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4),
17267      &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
17268      &KFL4(3)
17269       COMPLEX FGK,HA(6,6),HC(6,6)
17270       REAL TIR,UIR
17271       CHARACTER CODE*9,MASS*9
17272 C...Local arrays.
17273       DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
17274       DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
17275   
17276 C...Functions: momentum in two-particle decays and four-product.
17277       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
17278  
17279 C...The F, Xi and Xj functions of Gunion and Kunszt
17280 C...(Phys. Rev. D33, 665, plus errata from the authors).
17281       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17282      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17283       DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17284      &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17285       DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17286      &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17287      &2D0*(D34/D56+D56/D34))
17288  
17289 C...Some general constants.
17290       XW=PARU(102)
17291       XWV=XW
17292       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17293       XW1=1D0-XW
17294       SQMZ=PMAS(23,1)**2
17295  
17296       GMMZ=PMAS(23,1)*PMAS(23,2)
17297       SQMW=PMAS(24,1)**2
17298       GMMW=PMAS(24,1)*PMAS(24,2)
17299       SH=VINT(44)
17300  
17301 C...Boost and rotate to rest frame of incoming partons, 
17302 C...to get proper amount of smearing of decay angles.
17303       IBST=0
17304       IF(IRES.EQ.0) THEN
17305         IBST=1
17306         IIN1=MINT(84)+1
17307         IIN2=MINT(84)+2
17308 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons 
17309 C...(101,102) are off shell and can have inconsistent momenta, resulting 
17310 C...in boosts larger than unity. However, the corresponding docu partons 
17311 C...(5,6) are kept on shell, and have consistent momenta that can be used 
17312 C...to derive this boost instead. Ultimately, should change the way the new 
17313 C...shower stores intermediate partons, but just using partons (5,6) for now 
17314 C...does define the boost and furnishes a quick and much needed solution.
17315         IF (MINT(35).EQ.3) THEN
17316           IIN1=MINT(83)+5
17317           IIN2=MINT(83)+6
17318         ENDIF
17319         ETOTIN=P(IIN1,4)+P(IIN2,4)
17320         BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17321         BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17322         BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17323         CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17324         PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17325         CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17326         THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17327         CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17328       ENDIF
17329  
17330 C...Reset original resonance configuration.
17331       DO 100 JT=1,8
17332         IREF(1,JT)=0
17333   100 CONTINUE
17334  
17335 C...Define initial one, two or three objects for subprocess.
17336       IHDEC=0
17337       IF(IRES.EQ.0) THEN
17338         ISUB=MINT(1)
17339         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17340           IREF(1,1)=MINT(84)+2+ISET(ISUB)
17341           IREF(1,4)=MINT(83)+6+ISET(ISUB)
17342           JTMAX=1
17343         ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17344           IREF(1,1)=MINT(84)+1+ISET(ISUB)
17345           IREF(1,2)=MINT(84)+2+ISET(ISUB)
17346           IREF(1,4)=MINT(83)+5+ISET(ISUB)
17347           IREF(1,5)=MINT(83)+6+ISET(ISUB)
17348           JTMAX=2
17349         ELSEIF(ISET(ISUB).EQ.5) THEN
17350           IREF(1,1)=MINT(84)+3
17351           IREF(1,2)=MINT(84)+4
17352           IREF(1,3)=MINT(84)+5
17353           IREF(1,4)=MINT(83)+7
17354           IREF(1,5)=MINT(83)+8
17355           IREF(1,6)=MINT(83)+9
17356           JTMAX=3
17357         ENDIF
17358  
17359 C...Define original resonance for odd cases.
17360       ELSE
17361         ISUB=0
17362         IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17363      &  IHDEC=1
17364         IF(IHDEC.EQ.1) ISUB=3
17365         IREF(1,1)=IRES
17366         IREF(1,4)=K(IRES,3)
17367         IRESTM=IRES
17368         IF(IREF(1,4).GT.MINT(84)) THEN
17369   110     ITMPMO=IREF(1,4)
17370           IF(K(ITMPMO,2).EQ.94) THEN
17371             IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17372             IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17373           ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17374             IRESTM=ITMPMO
17375 C...Explicitly check that reference particle exists, otherwise stop recursion
17376             IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17377               IREF(1,4)=K(ITMPMO,3)
17378               GOTO 110
17379             ENDIF
17380           ENDIF
17381         ENDIF
17382         IF(IREF(1,4).GT.MINT(84)) THEN
17383           EMATCH=1D10
17384           IREF14=IREF(1,4)
17385           DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17386             IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17387      &      EMATCH) THEN
17388               IREF(1,4)=II
17389               EMATCH=ABS(P(II,4)-P(IREF14,4))
17390             ENDIF
17391   120     CONTINUE
17392         ENDIF
17393         JTMAX=1
17394       ENDIF
17395  
17396 C...Check if initial resonance has been moved (in resonance + jet).
17397       DO 140 JT=1,3
17398         IF(IREF(1,JT).GT.0) THEN
17399           IF(K(IREF(1,JT),1).GT.10) THEN
17400             KFA=IABS(K(IREF(1,JT),2))
17401             IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17402               KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17403               KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17404               IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17405                 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17406               ENDIF
17407               IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17408                 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17409               ENDIF
17410               DO 130 I=IREF(1,JT)+1,N
17411                 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17412      &          I.EQ.KDA2)) THEN
17413                   IREF(1,JT)=I
17414                   KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17415                   KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17416                   IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17417                     IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17418                   ENDIF
17419                   IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17420                     IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17421                   ENDIF
17422                 ENDIF
17423   130         CONTINUE
17424             ELSE
17425               KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17426               IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17427             ENDIF
17428           ENDIF
17429         ENDIF
17430   140 CONTINUE
17431  
17432 C...Set decay vertex for initial resonances
17433       DO 160 JT=1,JTMAX
17434         DO 150 I=1,4
17435           V(IREF(1,JT),I)=0D0
17436   150   CONTINUE
17437   160 CONTINUE
17438  
17439 C...Loop over decay history.
17440       NP=1
17441       IP=0
17442   170 IP=IP+1
17443       NINH=0
17444       JTMAX=2
17445       IF(IREF(IP,2).EQ.0) JTMAX=1
17446       IF(IREF(IP,3).NE.0) JTMAX=3
17447       IT4=0
17448       NSAV=N
17449  
17450 C...Check for Higgs which appears as decay product of user-process.
17451       IF(ISUB.EQ.0) THEN
17452         IHDEC=0
17453         IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17454      &  .EQ.36) IHDEC=1
17455         IF(IHDEC.EQ.1) ISUB=3
17456       ENDIF
17457  
17458 C...Start treatment of one, two or three resonances in parallel.
17459   180 N=NSAV
17460       DO 340 JT=1,JTMAX
17461         ID=IREF(IP,JT)
17462         KDCY(JT)=0
17463         KFL1(JT)=0
17464         KFL2(JT)=0
17465         KFL3(JT)=0
17466         KFL4(JT)=0
17467         KEQL(JT)=0
17468         NSD(JT)=ID
17469         ITJUNC(JT)=0
17470  
17471 C...Check whether particle can/is allowed to decay.
17472         IF(ID.EQ.0) GOTO 330
17473         KFA=IABS(K(ID,2))
17474         KCA=PYCOMP(KFA)
17475         IF(MWID(KCA).EQ.0) GOTO 330
17476         IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17477         IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17478      &  KFA.EQ.18) IT4=IT4+1
17479         K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17480         K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17481  
17482 C...Choose lifetime and determine decay vertex.
17483         IF(K(ID,1).EQ.5) THEN
17484           V(ID,5)=0D0
17485         ELSEIF(K(ID,1).NE.4) THEN
17486           V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17487         ENDIF
17488         DO 190 J=1,4
17489           VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17490   190   CONTINUE
17491  
17492 C...Determine whether decay allowed or not.
17493         MOUT=0
17494         IF(MSTJ(22).EQ.2) THEN
17495           IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17496         ELSEIF(MSTJ(22).EQ.3) THEN
17497           IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17498         ELSEIF(MSTJ(22).EQ.4) THEN
17499           IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17500           IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17501         ENDIF
17502         IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17503           K(ID,1)=4
17504           GOTO 330
17505         ENDIF
17506  
17507 C...Info for selection of decay channel: sign, pairings.
17508         IF(KCHG(KCA,3).EQ.0) THEN
17509           IPM=2
17510         ELSE
17511           IPM=(5-ISIGN(1,K(ID,2)))/2
17512         ENDIF
17513         KFB=0
17514         IF(JTMAX.EQ.2) THEN
17515           KFB=IABS(K(IREF(IP,3-JT),2))
17516         ELSEIF(JTMAX.EQ.3) THEN
17517           JT2=JT+1-3*(JT/3)
17518           KFB=IABS(K(IREF(IP,JT2),2))
17519           IF(KFB.NE.KFA) THEN
17520             JT2=JT+2-3*((JT+1)/3)
17521             KFB=IABS(K(IREF(IP,JT2),2))
17522           ENDIF
17523         ENDIF
17524  
17525 C...Select decay channel.
17526         IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17527      &  ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17528         CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17529         WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17530         IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17531         IF(WDTE0S.LE.0D0) GOTO 330
17532         RKFL=WDTE0S*PYR(0)
17533         IDL=0
17534   200   IDL=IDL+1
17535         IDC=IDL+MDCY(KCA,2)-1
17536         RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17537         IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17538         IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17539  
17540         NPROD=0
17541 C...Read out flavours and colour charges of decay channel chosen.
17542         KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17543         IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17544         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17545         KFC1A=PYCOMP(IABS(KFL1(JT)))
17546         IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17547         NPROD=NPROD+1
17548         KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17549         IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17550         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17551         KFC2A=PYCOMP(IABS(KFL2(JT)))
17552         IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17553         KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17554         IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17555         NPROD=NPROD+1
17556         KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17557         KCQ3(JT)=0
17558         KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
17559         KCQ4(JT)=0        
17560         IF(KFL3(JT).NE.0) THEN
17561           KFC3A=PYCOMP(IABS(KFL3(JT)))
17562           IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17563           KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17564           IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17565           NPROD=NPROD+1
17566           IF(KFL4(JT).NE.0) THEN
17567             KFC4A=PYCOMP(IABS(KFL4(JT)))
17568             IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
17569             KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
17570             IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
17571             NPROD=NPROD+1
17572           ENDIF
17573         ENDIF
17574  
17575 C...Set/save further info on channel.
17576         KDCY(JT)=1
17577         IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17578         NSD(JT)=N
17579         HGZ(JT,1)=VINT(111)
17580         HGZ(JT,2)=VINT(112)
17581         HGZ(JT,3)=VINT(114)
17582         JTZ=JT
17583  
17584         PXSUM=0D0
17585 C...Select masses; to begin with assume resonances narrow.
17586         DO 220 I=1,4
17587           P(N+I,5)=0D0
17588           PMMN(I)=0D0
17589           IF(I.EQ.1) THEN
17590             KFLW=IABS(KFL1(JT))
17591             KCW=KFC1A
17592           ELSEIF(I.EQ.2) THEN
17593             KFLW=IABS(KFL2(JT))
17594             KCW=KFC2A
17595           ELSEIF(I.EQ.3) THEN
17596             IF(KFL3(JT).EQ.0) GOTO 220
17597             KFLW=IABS(KFL3(JT))
17598             KCW=KFC3A
17599           ELSEIF(I.EQ.4) THEN
17600             IF(KFL4(JT).EQ.0) GOTO 220
17601             KFLW=IABS(KFL4(JT))
17602             KCW=KFC4A
17603           ENDIF
17604           P(N+I,5)=PMAS(KCW,1)
17605           PXSUM=PXSUM+P(N+I,5)
17606 CMRENNA++
17607 C...This prevents SUSY/t particles from becoming too light.
17608           IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17609             PMMN(I)=PMAS(KCW,1)
17610             DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17611               IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17612                 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17613      &              PMAS(PYCOMP(KFDP(IDC,2)),1)
17614                 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17615      &              PMAS(PYCOMP(KFDP(IDC,3)),1)
17616                 IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
17617      &              PMAS(PYCOMP(KFDP(IDC,4)),1)
17618                 PMMN(I)=MIN(PMMN(I),PMSUM)
17619               ENDIF
17620  210        CONTINUE
17621 C   MRENNA--
17622           ELSEIF(KFLW.EQ.6) THEN
17623             PMMN(I)=PMAS(24,1)+PMAS(5,1)
17624           ENDIF
17625 C...UED: select a graviton mass from continuous distribution
17626 C...(stored in PMAS(39,1) so no value returned)
17627           IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39) 
17628      &         CALL PYGRAM(1)
17629  220    CONTINUE
17630         
17631 C...Check which two out of three are widest.
17632         IWID1=1
17633         IWID2=2
17634         PWID1=PMAS(KFC1A,2)
17635         PWID2=PMAS(KFC2A,2)
17636         KFLW1=IABS(KFL1(JT))
17637         KFLW2=IABS(KFL2(JT))
17638         IF(KFL3(JT).NE.0) THEN
17639           PWID3=PMAS(KFC3A,2)
17640           IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17641             IWID1=3
17642             PWID1=PWID3
17643             KFLW1=IABS(KFL3(JT))
17644           ELSEIF(PWID3.GT.PWID2) THEN
17645             IWID2=3
17646             PWID2=PWID3
17647             KFLW2=IABS(KFL3(JT))
17648           ENDIF
17649         ENDIF
17650         IF(KFL4(JT).NE.0) THEN
17651           PWID4=PMAS(KFC4A,2)
17652           IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17653             IWID1=4
17654             PWID1=PWID4
17655             KFLW1=IABS(KFL4(JT))
17656           ELSEIF(PWID4.GT.PWID2) THEN
17657             IWID2=4
17658             PWID2=PWID4
17659             KFLW2=IABS(KFL4(JT))
17660           ENDIF
17661         ENDIF
17662  
17663 C...If all narrow then only check that masses consistent.
17664         IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17665      &  PWID2.LT.PARP(41))) THEN
17666 CMRENNA++
17667 C....Handle near degeneracy cases.
17668           IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17669             IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17670               P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17671               IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17672             ENDIF
17673           ENDIF
17674 CMRENNA--
17675           IF(PXSUM.GT.P(ID,5)) THEN
17676             CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17677             MINT(51)=1
17678             GOTO 720
17679           ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
17680             CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large')
17681             MINT(51)=1
17682             GOTO 720
17683           ENDIF
17684  
17685 C...For three wide resonances select narrower of three
17686 C...according to BW decoupled from rest.
17687         ELSE
17688           PMTOT=P(ID,5)
17689           IF(KFL3(JT).NE.0) THEN
17690             IWID3=6-IWID1-IWID2
17691             KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17692      &      KFLW1-KFLW2
17693             LOOP=0
17694   230       LOOP=LOOP+1
17695             P(N+IWID3,5)=PYMASS(KFLW3)
17696             IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17697             PMTOT=PMTOT-P(N+IWID3,5)
17698           ENDIF
17699 C...Select other two correlated within remaining phase space.
17700           IF(IP.EQ.1) THEN
17701             CKIN45=CKIN(45)
17702             CKIN47=CKIN(47)
17703             CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17704             CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17705             CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17706      &      P(N+IWID2,5))
17707             CKIN(45)=CKIN45
17708             CKIN(47)=CKIN47
17709           ELSE
17710             CKIN(49)=PMMN(IWID1)
17711             CKIN(50)=PMMN(IWID2)
17712             CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17713      &      P(N+IWID2,5))
17714             CKIN(49)=0D0
17715             CKIN(50)=0D0
17716           ENDIF
17717           IF(MINT(51).EQ.1) GOTO 720
17718         ENDIF
17719  
17720 C...Begin fill decay products, with colour flow for coloured objects.
17721         MSTU10=MSTU(10)
17722         MSTU(10)=1
17723         MSTU(19)=1
17724 
17725 
17726 C...Three-body decays 
17727         IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN
17728           DO 250 I=N+1,N+NPROD
17729             DO 240 J=1,5
17730               K(I,J)=0
17731               V(I,J)=0D0
17732   240       CONTINUE
17733             MCT(I,1)=0
17734             MCT(I,2)=0
17735   250     CONTINUE
17736           K(N+1,1)=1
17737           K(N+1,2)=KFL1(JT)
17738           K(N+2,1)=1
17739           K(N+2,2)=KFL2(JT)
17740           K(N+3,1)=1
17741           K(N+3,2)=KFL3(JT)
17742           IF(KFL4(JT).NE.0) THEN
17743             K(N+4,1)=1
17744             K(N+4,2)=KFL4(JT)
17745           ENDIF
17746           IDIN=ID
17747 
17748 C...Generate kinematics (default is flat)
17749           IF(KFL4(JT).EQ.0) THEN
17750             CALL PYTBDY(IDIN)
17751           ELSE
17752             PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
17753             ND=4
17754             PV(1,1)=0D0
17755             PV(1,2)=0D0
17756             PV(1,3)=0D0
17757             PV(1,4)=P(IDIN,5)
17758             PV(1,5)=P(IDIN,5)
17759 C...Calculate maximum weight ND-particle decay.
17760             PV(ND,5)=P(N+ND,5)
17761             WTMAX=1D0/WTCOR(ND-2)
17762             PMAX=PV(1,5)-PS+P(N+ND,5)
17763             PMIN=0D0
17764             DO 381 IL=ND-1,1,-1
17765               PMAX=PMAX+P(N+IL,5)
17766               PMIN=PMIN+P(N+IL+1,5)
17767               WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
17768  381        CONTINUE
17769 
17770 C...M-generator gives weight. If rejected, try again.
17771 
17772  411        RORD(1)=1D0
17773             DO 441 IL1=2,ND-1
17774               RSAV=PYR(0)
17775               DO 421 IL2=IL1-1,1,-1
17776                 IF(RSAV.LE.RORD(IL2)) GOTO 431
17777                 RORD(IL2+1)=RORD(IL2)
17778  421          CONTINUE
17779  431          RORD(IL2+1)=RSAV
17780  441        CONTINUE
17781             RORD(ND)=0D0
17782             WT=1D0
17783             DO 451 IL=ND-1,1,-1
17784               PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
17785      &             (PV(1,5)-PS)
17786               WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17787  451        CONTINUE
17788             IF(WT.LT.PYR(0)*WTMAX) GOTO 411
17789 
17790 C...Perform two-particle decays in respective CM frame.
17791             DO 481 IL=1,ND-1
17792               PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17793               UE(3)=2D0*PYR(0)-1D0
17794               PHIX=PARU(2)*PYR(0)
17795               UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
17796               UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
17797               DO 471 J=1,3
17798                 P(N+IL,J)=PA*UE(J)
17799                 PV(IL+1,J)=-PA*UE(J)
17800  471          CONTINUE
17801               P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
17802               PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
17803  481        CONTINUE
17804 
17805 C...Lorentz transform decay products to lab frame.
17806             DO 491 J=1,4
17807               P(N+ND,J)=PV(ND,J)
17808  491        CONTINUE
17809             DO 531 IL=ND-1,1,-1
17810               DO 501 J=1,3
17811                 BE(J)=PV(IL,J)/PV(IL,4)
17812  501          CONTINUE
17813               GA=PV(IL,4)/PV(IL,5)
17814               DO 521 I=N+IL,N+ND
17815                 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
17816                 DO 511 J=1,3
17817                   P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
17818  511            CONTINUE
17819                 P(I,4)=GA*(P(I,4)+BEP)
17820  521          CONTINUE
17821  531        CONTINUE
17822 
17823           ENDIF
17824 
17825 C...Set generic colour flows whenever unambiguous,
17826 C...(independently of the order of the decay products)
17827 C...Sum up total colour content
17828           NANT=0
17829           NTRI=0
17830           NOCT=0
17831           KCQ(0)=KCQM(JT)
17832           KCQ(1)=KCQ1(JT)
17833           KCQ(2)=KCQ2(JT)
17834           KCQ(3)=KCQ3(JT)
17835           KCQ(4)=KCQ4(JT)
17836           DO 255 J=0,NPROD
17837             IF (KCQ(J).EQ.-1) THEN
17838               NANT=NANT+1
17839               IANT(NANT)=N+J
17840             ELSEIF (KCQ(J).EQ.1) THEN
17841               NTRI=NTRI+1              
17842               ITRI(NTRI)=N+J
17843             ELSEIF (KCQ(J).EQ.2) THEN 
17844               NOCT=NOCT+1
17845               IOCT(NOCT)=N+J
17846             ENDIF
17847  255      CONTINUE
17848           
17849 C...Set color flow for generic 1 -> N processes (N arbitrary)
17850           IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17851 C...All singlets: do nothing
17852             
17853           ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17854 C...Two octets, zero triplets, n singlets:
17855             IF (KCQ(0).EQ.2) THEN
17856 C...8 -> 8 + n(1) 
17857               K(ID,4)=K(ID,4)+IOCT(2)
17858               K(ID,5)=K(ID,5)+IOCT(2)
17859               K(IOCT(2),1)=3
17860               K(IOCT(2),4)=MSTU(5)*ID
17861               K(IOCT(2),5)=MSTU(5)*ID
17862               MCT(IOCT(2),1)=MCT(ID,1)
17863               MCT(IOCT(2),2)=MCT(ID,2)
17864             ELSE
17865 C...1 -> 8 + 8 + n(1)
17866               K(IOCT(1),1)=3
17867               K(IOCT(1),4)=MSTU(5)*IOCT(2)
17868               K(IOCT(1),5)=MSTU(5)*IOCT(2)
17869               K(IOCT(2),1)=3
17870               K(IOCT(2),4)=MSTU(5)*IOCT(1)
17871               K(IOCT(2),5)=MSTU(5)*IOCT(1)
17872               NCT=NCT+1
17873               MCT(IOCT(1),1)=NCT
17874               MCT(IOCT(2),2)=NCT
17875               NCT=NCT+1
17876               MCT(IOCT(2),1)=NCT
17877               MCT(IOCT(1),2)=NCT
17878             ENDIF
17879             
17880           ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17881 C...Two triplets, zero octets, n singlets.            
17882             IF (KCQ(0).EQ.1) THEN
17883 C...3 -> 3 + n(1)
17884               K(ID,4)=K(ID,4)+ITRI(2)
17885               K(ITRI(2),1)=3
17886               K(ITRI(2),4)=MSTU(5)*ID
17887               MCT(ITRI(2),1)=MCT(ID,1)
17888             ELSEIF (KCQ(0).EQ.-1) THEN
17889 C...3bar -> 3bar + n(1)              
17890               K(ID,5)=K(ID,5)+IANT(2)
17891               K(IANT(2),1)=3
17892               K(IANT(2),5)=MSTU(5)*ID
17893               MCT(IANT(2),2)=MCT(ID,2)
17894             ELSE
17895 C...1 -> 3 + 3bar + n(1)
17896               K(ITRI(1),1)=3
17897               K(ITRI(1),4)=MSTU(5)*IANT(1)
17898               K(IANT(1),1)=3
17899               K(IANT(1),5)=MSTU(5)*ITRI(1)
17900               NCT=NCT+1
17901               MCT(ITRI(1),1)=NCT
17902               MCT(IANT(1),2)=NCT
17903             ENDIF
17904             
17905           ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17906 C...Two triplets, one octet, n singlets.            
17907             IF (KCQ(0).EQ.2) THEN
17908 C...8 -> 3 + 3bar + n(1)
17909               K(ID,4)=K(ID,4)+ITRI(1)
17910               K(ID,5)=K(ID,5)+IANT(1)
17911               K(ITRI(1),1)=3
17912               K(ITRI(1),4)=MSTU(5)*ID
17913               K(IANT(1),1)=3
17914               K(IANT(1),5)=MSTU(5)*ID
17915               MCT(ITRI(1),1)=MCT(ID,1)
17916               MCT(IANT(1),2)=MCT(ID,2)
17917             ELSEIF (KCQ(0).EQ.1) THEN
17918 C...3 -> 8 + 3 + n(1)
17919               K(ID,4)=K(ID,4)+IOCT(1)
17920               K(IOCT(1),1)=3
17921               K(IOCT(1),4)=MSTU(5)*ID
17922               K(IOCT(1),5)=MSTU(5)*ITRI(2)
17923               K(ITRI(2),1)=3
17924               K(ITRI(2),4)=MSTU(5)*IOCT(1)
17925               MCT(IOCT(1),1)=MCT(ID,1)
17926               NCT=NCT+1
17927               MCT(IOCT(1),2)=NCT
17928               MCT(ITRI(2),1)=NCT
17929             ELSEIF (KCQ(0).EQ.-1) THEN
17930 C...3bar -> 8 + 3bar + n(1)
17931               K(ID,5)=K(ID,5)+IOCT(1)
17932               K(IOCT(1),1)=3
17933               K(IOCT(1),5)=MSTU(5)*ID
17934               K(IOCT(1),4)=MSTU(5)*IANT(2)
17935               K(IANT(2),1)=3
17936               K(IANT(2),5)=MSTU(5)*IOCT(1)
17937               MCT(IOCT(1),2)=MCT(ID,2)
17938               NCT=NCT+1
17939               MCT(IOCT(1),1)=NCT
17940               MCT(IANT(2),2)=NCT
17941             ELSE
17942 C...1 -> 3 + 3bar + 8 + n(1)
17943               K(ITRI(1),1)=3
17944               K(ITRI(1),4)=MSTU(5)*IOCT(1)
17945               K(IOCT(1),1)=3
17946               K(IOCT(1),5)=MSTU(5)*ITRI(1)
17947               K(IOCT(1),4)=MSTU(5)*IANT(1)
17948               K(IANT(1),1)=3
17949               K(IANT(1),5)=MSTU(5)*IOCT(1)
17950               NCT=NCT+1
17951               MCT(ITRI(1),1)=NCT
17952               MCT(IOCT(1),2)=NCT
17953               NCT=NCT+1
17954               MCT(IOCT(1),1)=NCT
17955               MCT(IANT(1),2)=NCT
17956             ENDIF
17957          ELSEIF(NTRI+NANT.EQ.4) THEN
17958 C...
17959             IF (KCQ(0).EQ.1) THEN
17960 C...3 -> 3 + n(1) -> 3 + 3bar
17961               K(ID,4)=K(ID,4)+ITRI(2)
17962               K(ITRI(2),1)=3
17963               K(ITRI(2),4)=MSTU(5)*ID
17964               MCT(ITRI(2),1)=MCT(ID,1)
17965               K(ITRI(3),1)=3
17966               K(ITRI(3),4)=MSTU(5)*IANT(1)
17967               K(IANT(1),1)=3
17968               K(IANT(1),5)=MSTU(5)*ITRI(3)
17969               NCT=NCT+1
17970               MCT(ITRI(3),1)=NCT
17971               MCT(IANT(1),2)=NCT
17972             ELSEIF (KCQ(0).EQ.-1) THEN
17973 C...3bar -> 3bar + n(1) -> 3 + 3bar             
17974               K(ID,5)=K(ID,5)+IANT(2)
17975               K(IANT(2),1)=3
17976               K(IANT(2),5)=MSTU(5)*ID
17977               MCT(IANT(2),2)=MCT(ID,2)
17978               K(ITRI(1),1)=3
17979               K(ITRI(1),4)=MSTU(5)*IANT(3)
17980               K(IANT(3),1)=3
17981               K(IANT(3),5)=MSTU(5)*ITRI(1)
17982               NCT=NCT+1
17983               MCT(ITRI(1),1)=NCT
17984               MCT(IANT(3),2)=NCT
17985             ENDIF
17986           ELSEIF(KFL4(JT).NE.0) THEN
17987             CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
17988 CPS-- End of generic cases 
17989 C...(could three octets also be handled?)
17990 C...(could (some of) the RPV cases be made generic as well?)
17991 
17992 C...Special cases (= old treatment)
17993 C...Set colour flow for t -> W + b + Z.
17994           ELSEIF(KFA.EQ.6) THEN
17995             K(N+2,1)=3
17996             ISID=4
17997             IF(KCQM(JT).EQ.-1) ISID=5
17998             IDAU=N+2
17999             K(ID,ISID)=K(ID,ISID)+IDAU
18000             K(IDAU,ISID)=MSTU(5)*ID
18001  
18002 C...Set colour flow in three-body decays - programmed as special cases.
18003  
18004           ELSEIF(KFC2A.LE.6) THEN
18005             K(N+2,1)=3
18006             K(N+3,1)=3
18007             ISID=4
18008             IF(KFL2(JT).LT.0) ISID=5
18009             K(N+2,ISID)=MSTU(5)*(N+3)
18010             K(N+3,9-ISID)=MSTU(5)*(N+2)
18011 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
18012           ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
18013      &          .AND.KFL3(JT).NE.0) THEN
18014             KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
18015 C...3-body decays of squarks to colour singlets plus one quark
18016             IF (KQSUMA.EQ.1) THEN
18017 C...Find quark
18018               IQ=0
18019               IF (KCQ1(JT).NE.0) IQ=1
18020               IF (KCQ2(JT).NE.0) IQ=2
18021               IF (KCQ3(JT).NE.0) IQ=3
18022               ISID=4
18023               IF (K(N+IQ,2).LT.0) ISID=5
18024               K(N+IQ,1)=3
18025               K(ID,ISID)=K(ID,ISID)+(N+IQ)
18026               K(N+IQ,ISID)=MSTU(5)*ID
18027             ENDIF
18028 C...PS--
18029           ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
18030             K(N+1,1)=3
18031             K(N+2,1)=3
18032             K(N+3,1)=3
18033             ISID=4
18034             IF(KFL2(JT).LT.0) ISID=5
18035             K(N+1,ISID)=MSTU(5)*(N+2)
18036             K(N+1,9-ISID)=MSTU(5)*(N+3)
18037             K(N+2,ISID)=MSTU(5)*(N+1)
18038             K(N+3,9-ISID)=MSTU(5)*(N+1)
18039           ELSEIF(KFA.EQ.KSUSY1+21) THEN
18040             K(N+2,1)=3
18041             K(N+3,1)=3
18042             ISID=4
18043             IF(KFL2(JT).LT.0) ISID=5
18044             K(ID,ISID)=K(ID,ISID)+(N+2)
18045             K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
18046             K(N+2,ISID)=MSTU(5)*ID
18047             K(N+3,9-ISID)=MSTU(5)*ID
18048 CMRENNA--
18049  
18050           ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
18051      &    IABS(KCQ2(JT)).EQ.1) THEN
18052             K(N+2,1)=3
18053             K(N+3,1)=3
18054             ISID=4
18055             IF(KFL2(JT).LT.0) ISID=5
18056             K(N+2,ISID)=MSTU(5)*(N+3)
18057             K(N+3,9-ISID)=MSTU(5)*(N+2)
18058           ENDIF
18059            
18060 CXXX      NSAV=N
18061           
18062 C...Set colour flow in three-body decays with baryon number violation.
18063 C...Neutralino and chargino decays first.
18064           KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
18065           IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
18066             ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
18067             K(N+4,4)=ITJUNC(JT)*MSTU(5)
18068 C...Insert junction to keep track of colours.
18069             IF(KCQ1(JT).NE.0) K(N+1,1)=3
18070             IF(KCQ2(JT).NE.0) K(N+2,1)=3
18071             IF(KCQ3(JT).NE.0) K(N+3,1)=3
18072 C...Set special junction codes:
18073             K(N+4,1)=42
18074             K(N+4,2)=88
18075  
18076 C...Order decay products by invariant mass. (will be used in PYSTRF).
18077             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)-
18078      &      P(N+1,3)*P(N+2,3)
18079             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)-
18080      &      P(N+1,3)*P(N+3,3)
18081             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)-
18082      &      P(N+2,3)*P(N+3,3)
18083             IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
18084               K(N+4,4)=N+3+K(N+4,4)
18085               K(N+4,5)=N+1+MSTU(5)*(N+2)
18086             ELSEIF(PM13.LT.PM23) THEN
18087               K(N+4,4)=N+2+K(N+4,4)
18088               K(N+4,5)=N+1+MSTU(5)*(N+3)
18089             ELSE
18090               K(N+4,4)=N+1+K(N+4,4)
18091               K(N+4,5)=N+2+MSTU(5)*(N+3)
18092             ENDIF
18093             DO 260 J=1,5
18094               P(N+4,J)=0D0
18095               V(N+4,J)=0D0
18096   260       CONTINUE
18097 C...Connect daughters to junction.
18098             DO 270 II=N+1,N+3
18099               K(II,4)=0
18100               K(II,5)=0
18101               K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
18102   270       CONTINUE
18103 C...Particle counter should be stepped up one extra for junction.
18104             N=N+1
18105  
18106 C...Gluino decays.
18107           ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
18108             ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
18109             K(N+4,4)=ITJUNC(JT)*MSTU(5)
18110 C...Insert junction to keep track of colours.
18111             IF(KCQ1(JT).NE.0) K(N+1,1)=3
18112             IF(KCQ2(JT).NE.0) K(N+2,1)=3
18113             IF(KCQ3(JT).NE.0) K(N+3,1)=3
18114             K(N+4,1)=42
18115             K(N+4,2)=88
18116             DO 280 J=1,5
18117               P(N+4,J)=0D0
18118               V(N+4,J)=0D0
18119   280       CONTINUE
18120             CTMSUM=0D0
18121             DO 290 II=N+1,N+3
18122               K(II,4)=0
18123               K(II,5)=0
18124 C...Start by connecting all daughters to junction.
18125               K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
18126 C...Only consider colour topologies with off shell resonances.
18127               RMQ1=PMAS(PYCOMP(K(II,2)),1)
18128               RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
18129               RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
18130               IF (RMGLU-RMQ1.LT.RMRES) THEN
18131 C...Calculate propagators for each colour topology.
18132                 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
18133      &               *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
18134                 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
18135               ELSE
18136                 CTM2(II-N)=0D0
18137               ENDIF
18138               CTMSUM=CTMSUM+CTM2(II-N)
18139   290       CONTINUE
18140             CTMSUM=PYR(0)*CTMSUM
18141 C...Select colour topology J, with most off shell least likely.
18142             J=0
18143   300       J=J+1
18144             CTMSUM=CTMSUM-CTM2(J)
18145             IF (CTMSUM.GT.0D0) GOTO 300
18146 C...The lucky winner gets its colour (anti-colour) directly from gluino.
18147             K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
18148             K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
18149 C...The other gluino colour is connected to junction
18150             K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
18151      &      MSTU(5)
18152             K(N+4,4)=K(N+4,4)+ID
18153 C...Lastly, connect junction to remaining daughters.
18154             K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
18155 C...Particle counter should be stepped up one extra for junction.
18156             N=N+1
18157           ENDIF
18158  
18159 C...Update particle counter.
18160           N=N+NPROD
18161 
18162 C...2) Everything else two-body decay.
18163         ELSE
18164           CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
18165           MCT(N-1,1)=0
18166           MCT(N-1,2)=0
18167           MCT(N,1)=0
18168           MCT(N,2)=0
18169 C...First set colour flow as if mother colour singlet.
18170           IF(KCQ1(JT).NE.0) THEN
18171             K(N-1,1)=3
18172             IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
18173             IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
18174           ENDIF
18175           IF(KCQ2(JT).NE.0) THEN
18176             K(N,1)=3
18177             IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
18178             IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
18179           ENDIF
18180 C...Then redirect colour flow if mother (anti)triplet.
18181           IF(KCQM(JT).EQ.0) THEN
18182           ELSEIF(KCQM(JT).NE.2) THEN
18183             ISID=4
18184             IF(KCQM(JT).EQ.-1) ISID=5
18185             IDAU=N-1
18186             IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
18187             K(ID,ISID)=K(ID,ISID)+IDAU
18188             K(IDAU,ISID)=MSTU(5)*ID
18189 C...Then redirect colour flow if mother octet.
18190           ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
18191             IDAU=N-1
18192             IF(KCQ1(JT).EQ.0) IDAU=N
18193             K(ID,4)=K(ID,4)+IDAU
18194             K(ID,5)=K(ID,5)+IDAU
18195             K(IDAU,4)=MSTU(5)*ID
18196             K(IDAU,5)=MSTU(5)*ID
18197           ELSE
18198             ISID=4
18199             IF(KCQ1(JT).EQ.-1) ISID=5
18200             IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
18201             K(ID,ISID)=K(ID,ISID)+(N-1)
18202             K(ID,9-ISID)=K(ID,9-ISID)+N
18203             K(N-1,ISID)=MSTU(5)*ID
18204             K(N,9-ISID)=MSTU(5)*ID
18205           ENDIF
18206  
18207 C...Insert junction
18208           IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
18209             N=N+1
18210 C...~q* mother: type 3 junction. ~q mother: type 4.
18211             ITJUNC(JT)=(7+KCQM(JT))/2
18212 C...Specify junction KF and set colour flow from junction
18213             K(N,1)=42
18214             K(N,2)=88
18215             K(N,3)=ID
18216 C...Junction type encoded together with mother:
18217             K(N,4)=ID+ITJUNC(JT)*MSTU(5)
18218             K(N,5)=N-1+MSTU(5)*(N-2)
18219 C...Zero P and V for junction (V filled later)
18220             DO 310 J=1,5
18221               P(N,J)=0D0
18222               V(N,J)=0D0
18223   310       CONTINUE
18224 C...Set colour flow from mother to junction
18225             K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
18226 C...Set colour flow from daughters to junction
18227             DO 320 II=N-2,N-1
18228               K(II,4) = 0
18229               K(II,5) = 0
18230 C...(Anti-)colour mother is junction.
18231               K(II,1+ITJUNC(JT)) = MSTU(5)*N
18232   320       CONTINUE
18233           ENDIF
18234         ENDIF
18235  
18236 C...End loop over resonances for daughter flavour and mass selection.
18237         MSTU(10)=MSTU10
18238   330   IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
18239      &  NINH=NINH+1
18240         IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
18241      &  KFL1(JT).EQ.0) THEN
18242           WRITE(CODE,'(I9)') K(ID,2)
18243           WRITE(MASS,'(F9.3)') P(ID,5)
18244           CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
18245      &    CODE//' with mass'//MASS)
18246           MINT(51)=1
18247           GOTO 720
18248         ENDIF
18249   340 CONTINUE
18250  
18251 C...Check for allowed combinations. Skip if no decays.
18252       IF(JTMAX.EQ.1) THEN
18253         IF(KDCY(1).EQ.0) GOTO 710
18254       ELSEIF(JTMAX.EQ.2) THEN
18255         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
18256         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18257         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18258       ELSEIF(JTMAX.EQ.3) THEN
18259         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
18260         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18261         IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18262         IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18263         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18264         IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18265         IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18266       ENDIF
18267  
18268 C...Special case: matrix element option for Z0 decay to quarks.
18269       IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
18270      &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
18271  
18272 C...Check consistency of MSTJ options set.
18273         IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
18274           CALL PYERRM(6,
18275      &    '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
18276           MSTJ(110)=1
18277         ENDIF
18278         IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
18279           CALL PYERRM(6,
18280      &    '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
18281  
18282           MSTJ(111)=0
18283         ENDIF
18284  
18285 C...Select alpha_strong behaviour.
18286         MST111=MSTU(111)
18287         PAR112=PARU(112)
18288         MSTU(111)=MSTJ(108)
18289         IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
18290      &  MSTU(111)=1
18291         PARU(112)=PARJ(121)
18292         IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
18293  
18294 C...Find axial fraction in total cross section for scalar gluon model.
18295         PARJ(171)=0D0
18296         IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
18297      &  (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
18298           POLL=1D0-PARJ(131)*PARJ(132)
18299           SFF=1D0/(16D0*XW*XW1)
18300           SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
18301      &    (PARJ(123)*PARJ(124))**2)
18302           SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
18303           VE=4D0*XW-1D0
18304           HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
18305           HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
18306      &    (PARJ(132)-PARJ(131)))
18307           KFLC=IABS(KFL1(1))
18308           PMQ=PYMASS(KFLC)
18309           QF=KCHG(KFLC,1)/3D0
18310           VQ=1D0
18311           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
18312      &    1D0-(2D0*PMQ/P(ID,5))**2))
18313           VF=SIGN(1D0,QF)-4D0*QF*XW
18314           RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
18315      &    VF**2*HF1W)+VQ**3*HF1W
18316           IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
18317         ENDIF
18318  
18319 C...Choice of jet configuration.
18320         CALL PYXJET(P(ID,5),NJET,CUT)
18321         KFLC=IABS(KFL1(1))
18322         KFLN=21
18323         IF(NJET.EQ.4) THEN
18324           CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
18325         ELSEIF(NJET.EQ.3) THEN
18326           CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
18327         ELSE
18328           MSTJ(120)=1
18329         ENDIF
18330  
18331 C...Fill jet configuration; return if incorrect kinematics.
18332         NC=N-2
18333         IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
18334           CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
18335         ELSEIF(NJET.EQ.2) THEN
18336           CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
18337         ELSEIF(NJET.EQ.3) THEN
18338           CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
18339         ELSEIF(KFLN.EQ.21) THEN
18340           CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18341      &    X12,X14)
18342         ELSE
18343           CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18344      &    X12,X14)
18345         ENDIF
18346         IF(MSTU(24).NE.0) THEN
18347           MINT(51)=1
18348           MSTU(111)=MST111
18349           PARU(112)=PAR112
18350           GOTO 720
18351         ENDIF
18352  
18353 C...Angular orientation according to matrix element.
18354         IF(MSTJ(106).EQ.1) THEN
18355           CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
18356           IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
18357           CTHE(1)=COS(THEZ)
18358           CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
18359           CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
18360         ENDIF
18361  
18362 C...Boost partons to Z0 rest frame.
18363         CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
18364      &  P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18365  
18366 C...Mark decayed resonance and add documentation lines,
18367         K(ID,1)=K(ID,1)+10
18368         IDOC=MINT(83)+MINT(4)
18369         DO 360 I=NC+1,N
18370           I1=MINT(83)+MINT(4)+1
18371           K(I,3)=I1
18372           IF(MSTP(128).GE.1) K(I,3)=ID
18373           IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18374             MINT(4)=MINT(4)+1
18375             K(I1,1)=21
18376             K(I1,2)=K(I,2)
18377             K(I1,3)=IREF(IP,4)
18378             DO 350 J=1,5
18379               P(I1,J)=P(I,J)
18380   350       CONTINUE
18381           ENDIF
18382   360   CONTINUE
18383  
18384 C...Generate parton shower.
18385         IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
18386           CALL PYSHOW(N-1,N,P(ID,5))
18387         ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
18388           NPART=2
18389           IPART(1)=N-1
18390           IPART(2)=N
18391           PTPART(1)=0.5D0*P(ID,5)
18392           PTPART(2)=PTPART(1)
18393           NCT=NCT+1
18394           IF(K(N-1,2).GT.0) THEN
18395             MCT(N-1,1)=NCT
18396             MCT(N,2)=NCT
18397           ELSE
18398             MCT(N-1,2)=NCT
18399             MCT(N,1)=NCT
18400           ENDIF
18401           CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18402         ENDIF
18403  
18404 C... End special case for Z0: skip ahead.
18405         MSTU(111)=MST111
18406         PARU(112)=PAR112
18407         GOTO 700
18408       ENDIF
18409  
18410 C...Order incoming partons and outgoing resonances.
18411       IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
18412      &NINH.EQ.0) THEN
18413         ILIN(1)=MINT(84)+1
18414         IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
18415         IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
18416      &  ILIN(1)=2*MINT(84)+3-ILIN(1)
18417         ILIN(2)=2*MINT(84)+3-ILIN(1)
18418         IMIN=1
18419         IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
18420      &  .EQ.36) IMIN=3
18421         IMAX=2
18422         IORD=1
18423         IF(K(IREF(IP,1),2).EQ.23) IORD=2
18424         IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18425         IAKIPD=IABS(K(IREF(IP,IORD),2))
18426         IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18427         IF(KDCY(IORD).EQ.0) IORD=3-IORD
18428  
18429 C...Order decay products of resonances.
18430         DO 370 JT=IORD,3-IORD,3-2*IORD
18431           IF(KDCY(JT).EQ.0) THEN
18432             ILIN(IMAX+1)=NSD(JT)
18433             IMAX=IMAX+1
18434           ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18435             ILIN(IMAX+1)=N+2*JT-1
18436             ILIN(IMAX+2)=N+2*JT
18437             IMAX=IMAX+2
18438             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18439             K(N+2*JT,2)=K(NSD(JT)+2,2)
18440           ELSE
18441             ILIN(IMAX+1)=N+2*JT
18442  
18443             ILIN(IMAX+2)=N+2*JT-1
18444             IMAX=IMAX+2
18445             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18446             K(N+2*JT,2)=K(NSD(JT)+2,2)
18447           ENDIF
18448   370   CONTINUE
18449  
18450 C...Find charge, isospin, left- and righthanded couplings.
18451         DO 390 I=IMIN,IMAX
18452           DO 380 J=1,4
18453             COUP(I,J)=0D0
18454   380     CONTINUE
18455           KFA=IABS(K(ILIN(I),2))
18456           IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18457           COUP(I,1)=KCHG(KFA,1)/3D0
18458           COUP(I,2)=(-1)**MOD(KFA,2)
18459           COUP(I,4)=-2D0*COUP(I,1)*XWV
18460           COUP(I,3)=COUP(I,2)+COUP(I,4)
18461   390   CONTINUE
18462  
18463 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18464         IF(ISUB.EQ.22) THEN
18465           DO 420 I=3,5,2
18466             I1=IORD
18467             IF(I.EQ.5) I1=3-IORD
18468             DO 410 J1=1,2
18469               DO 400 J2=1,2
18470                 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18471      &          16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18472      &          COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18473      &          COUP(I,J2+2)**2
18474   400         CONTINUE
18475   410       CONTINUE
18476   420     CONTINUE
18477           COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18478      &    (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18479           COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18480      &    (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18481  
18482           IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18483         ENDIF
18484       ENDIF
18485  
18486 C...Select angular orientation type - Z'/W' only.
18487       MZPWP=0
18488       IF(ISUB.EQ.141) THEN
18489         IF(PYR(0).LT.PARU(130)) MZPWP=1
18490         IF(IP.EQ.2) THEN
18491           IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18492           IAKIR=IABS(K(IREF(2,2),2))
18493           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18494           IF(IAKIR.LE.20) MZPWP=2
18495         ENDIF
18496         IF(IP.GE.3) MZPWP=2
18497       ELSEIF(ISUB.EQ.142) THEN
18498         IF(PYR(0).LT.PARU(136)) MZPWP=1
18499         IF(IP.EQ.2) THEN
18500           IAKIR=IABS(K(IREF(2,2),2))
18501           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18502           IF(IAKIR.LE.20) MZPWP=2
18503         ENDIF
18504         IF(IP.GE.3) MZPWP=2
18505       ENDIF
18506  
18507 C...Select random angles (begin of weighting procedure).
18508   430 DO 440 JT=1,JTMAX
18509         IF(KDCY(JT).EQ.0) GOTO 440
18510         IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18511           CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18512           IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18513           PHI(JT)=VINT(24)
18514         ELSE
18515           CTHE(JT)=2D0*PYR(0)-1D0
18516           PHI(JT)=PARU(2)*PYR(0)
18517         ENDIF
18518   440 CONTINUE
18519  
18520       IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18521 C...Construct massless four-vectors.
18522         DO 460 I=N+1,N+4
18523           K(I,1)=1
18524           DO 450 J=1,5
18525             P(I,J)=0D0
18526             V(I,J)=0D0
18527   450     CONTINUE
18528   460   CONTINUE
18529         DO 470 JT=1,JTMAX
18530           IF(KDCY(JT).EQ.0) GOTO 470
18531           ID=IREF(IP,JT)
18532           P(N+2*JT-1,3)=0.5D0*P(ID,5)
18533           P(N+2*JT-1,4)=0.5D0*P(ID,5)
18534           P(N+2*JT,3)=-0.5D0*P(ID,5)
18535           P(N+2*JT,4)=0.5D0*P(ID,5)
18536           CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18537      &    P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18538   470   CONTINUE
18539  
18540 C...Store incoming and outgoing momenta, with random rotation to
18541 C...avoid accidental zeroes in HA expressions.
18542         IF(ISUB.NE.0) THEN
18543           DO 490 I=IMIN,IMAX
18544             K(N+4+I,1)=1
18545             P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18546      &      P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18547             P(N+4+I,5)=P(ILIN(I),5)
18548             DO 480 J=1,3
18549               P(N+4+I,J)=P(ILIN(I),J)
18550   480       CONTINUE
18551   490     CONTINUE
18552   500     THERR=ACOS(2D0*PYR(0)-1D0)
18553           PHIRR=PARU(2)*PYR(0)
18554           CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18555           DO 520 I=IMIN,IMAX
18556             IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18557      &      P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18558             DO 510 J=1,4
18559               PK(I,J)=P(N+4+I,J)
18560   510       CONTINUE
18561   520     CONTINUE
18562         ENDIF
18563  
18564 C...Calculate internal products.
18565         IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18566      &  ISUB.EQ.142) THEN
18567           DO 540 I1=IMIN,IMAX-1
18568             DO 530 I2=I1+1,IMAX
18569               HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18570      &        PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18571      &        CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18572      &        SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18573      &        (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18574      &        CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18575               HC(I1,I2)=CONJG(HA(I1,I2))
18576               IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18577               IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18578               HA(I2,I1)=-HA(I1,I2)
18579               HC(I2,I1)=-HC(I1,I2)
18580   530       CONTINUE
18581   540     CONTINUE
18582         ENDIF
18583  
18584 C...Calculate four-products.
18585         IF(ISUB.NE.0) THEN
18586           DO 560 I=1,2
18587             DO 550 J=1,4
18588               PK(I,J)=-PK(I,J)
18589   550       CONTINUE
18590   560     CONTINUE
18591           DO 580 I1=IMIN,IMAX-1
18592             DO 570 I2=I1+1,IMAX
18593               PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18594      &        PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18595               PKK(I2,I1)=PKK(I1,I2)
18596   570       CONTINUE
18597   580     CONTINUE
18598         ENDIF
18599       ENDIF
18600  
18601       KFAGM=IABS(IREF(IP,7))
18602       IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18603 C...Isotropic decay selected by user.
18604         WT=1D0
18605         WTMAX=1D0
18606  
18607       ELSEIF(JTMAX.EQ.3) THEN
18608 C...Isotropic decay when three mother particles.
18609         WT=1D0
18610         WTMAX=1D0
18611  
18612       ELSEIF(IT4.GE.1) THEN
18613 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18614         WT=1D0
18615         WTMAX=1D0
18616  
18617       ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18618      &  IREF(IP,7).EQ.36) THEN
18619 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18620 C...CP-odd case added by Kari Ertresvag Myklevoll.
18621 C...Now also with mixed Higgs CP-states
18622         ETA=PARP(25)
18623         IF(IP.EQ.1) WTMAX=SH**2
18624         IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18625         KFA=IABS(K(IREF(IP,1),2))
18626         KFT=IABS(K(IREF(IP,2),2))
18627         
18628         IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18629      &  MSTP(25).GE.3) THEN
18630 C...For mixed CP states need epsilon product.
18631           P10=PK(3,4)
18632           P20=PK(4,4)
18633           P30=PK(5,4)
18634           P40=PK(6,4)
18635           P11=PK(3,1)
18636           P21=PK(4,1)
18637           P31=PK(5,1)
18638           P41=PK(6,1)
18639           P12=PK(3,2)
18640           P22=PK(4,2)
18641           P32=PK(5,2)
18642           P42=PK(6,2)
18643           P13=PK(3,3)
18644           P23=PK(4,3)
18645           P33=PK(5,3)
18646           P43=PK(6,3)
18647           EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18648      &      P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18649      &      P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18650      &      P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18651      &      P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18652      &      P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18653      &      P22*P30*P41+P13*P22*P31*P40
18654 C...For mixed CP states need gauge boson masses.
18655           XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18656      &      (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18657           XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18658      &      (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18659           XMV=PMAS(KFA,1)
18660         ENDIF
18661  
18662 C...Z decay
18663         IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18664           KFLF1A=IABS(KFL1(1))
18665           EF1=KCHG(KFLF1A,1)/3D0
18666           AF1=SIGN(1D0,EF1+0.1D0)
18667           VF1=AF1-4D0*EF1*XWV
18668           KFLF2A=IABS(KFL1(2))
18669           EF2=KCHG(KFLF2A,1)/3D0
18670           AF2=SIGN(1D0,EF2+0.1D0)
18671           VF2=AF2-4D0*EF2*XWV
18672           VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18673           IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18674      &      THEN
18675 C...CP-even decay
18676             WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18677      &        8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18678           ELSEIF(MSTP(25).LE.2) THEN
18679 C...CP-odd decay
18680             WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18681      &        -2*PKK(3,4)*PKK(5,6)
18682      &        -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18683      &        (PKK(3,4)*PKK(5,6))
18684      &        +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18685      &        (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18686           ELSE
18687 C...Mixed CP states.
18688             WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18689      &        +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18690      &        -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18691      &        -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18692      &        +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18693      &        -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18694      &        +PKK(3,4)*PKK(5,6)
18695      &        *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18696      &        +VA12AS*PKK(3,4)*PKK(5,6)
18697      &        *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18698      &        *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18699      &        /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18700      &          +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18701           ENDIF
18702  
18703 C...W decay
18704         ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18705           IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18706      &      THEN
18707 C...CP-even decay
18708             WT=16D0*PKK(3,5)*PKK(4,6)
18709           ELSEIF(MSTP(25).LE.2) THEN
18710 C...CP-odd decay
18711             WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18712      &        -2*PKK(3,4)*PKK(5,6)
18713      &        -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18714      &        (PKK(3,4)*PKK(5,6))
18715      &        +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18716      &        (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18717           ELSE
18718 C...Mixed CP states.
18719             WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18720      &        -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18721      &        +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18722      &        -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18723      &        +PKK(3,4)*PKK(5,6)
18724      &        *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18725      &        +PKK(3,4)*PKK(5,6)
18726      &        *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18727      &        *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18728      &        /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18729      &          +(2D0*ETA*XMA*XMB/XMV**2)**2)
18730           ENDIF
18731  
18732 C...No angular correlations in other Higgs decays.
18733         ELSE
18734           WT=WTMAX
18735         ENDIF
18736  
18737       ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18738      &  KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18739      &  THEN
18740 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18741         I1=IREF(IP,8)
18742         IF(MOD(KFAGM,2).EQ.0) THEN
18743           I2=N+1
18744           I3=N+2
18745         ELSE
18746           I2=N+2
18747           I3=N+1
18748         ENDIF
18749         I4=IREF(IP,2)
18750         WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18751      &  P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18752      &  P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18753         WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18754  
18755       ELSEIF(ISUB.EQ.1) THEN
18756 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18757         EI=KCHG(IABS(MINT(15)),1)/3D0
18758         AI=SIGN(1D0,EI+0.1D0)
18759         VI=AI-4D0*EI*XWV
18760         EF=KCHG(IABS(KFL1(1)),1)/3D0
18761         AF=SIGN(1D0,EF+0.1D0)
18762  
18763         VF=AF-4D0*EF*XWV
18764         RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18765         WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18766      &  (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18767         WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18768      &  (VI**2+AI**2)*VINT(114)*VF**2)
18769         WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18770      &  4D0*VI*AI*VINT(114)*VF*AF)
18771         WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18772      &  2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18773         WTMAX=2D0*(WT1+ABS(WT3))
18774  
18775       ELSEIF(ISUB.EQ.2) THEN
18776 C...Angular weight for W+/- -> 2 quarks/leptons.
18777         RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18778         RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18779         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18780         WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18781         WTMAX=4D0
18782  
18783       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18784 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18785 C...-> gluon/gamma + 2 quarks/leptons.
18786         CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18787      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18788      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18789         CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18790      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18791      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18792         CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18793      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18794      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18795         CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18796      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18797      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18798         WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18799      &  (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18800         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18801      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18802  
18803       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18804 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18805 C...-> gluon/gamma + 2 quarks/leptons.
18806         WT=PKK(1,3)**2+PKK(2,4)**2
18807         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18808  
18809       ELSEIF(ISUB.EQ.22) THEN
18810 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18811         S34=P(IREF(IP,IORD),5)**2
18812         S56=P(IREF(IP,3-IORD),5)**2
18813         TI=PKK(1,3)+PKK(1,4)+S34
18814         UI=PKK(1,5)+PKK(1,6)+S56
18815         TIR=REAL(TI)
18816         UIR=REAL(UI)
18817         FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18818         FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18819         FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18820         FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18821         FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18822         FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18823         FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18824         FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18825  
18826         WT=
18827      &  CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18828      &  CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18829      &  CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18830      &  CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18831         WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18832      &  (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18833      &  ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18834      &  1D0/UI**2))
18835  
18836       ELSEIF(ISUB.EQ.23) THEN
18837 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18838         D34=P(IREF(IP,IORD),5)**2
18839         D56=P(IREF(IP,3-IORD),5)**2
18840         DT=PKK(1,3)+PKK(1,4)+D34
18841         DU=PKK(1,5)+PKK(1,6)+D56
18842         FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18843         CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18844         CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18845         FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18846  
18847      &  REAL(CBWZ)*FGK(1,2,5,6,3,4))
18848         FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18849      &  REAL(CBWZ)*FGK(1,2,6,5,3,4))
18850         WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18851         WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18852      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18853  
18854       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18855 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18856 C...(or H0, or A0).
18857         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18858      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18859      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18860         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18861      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18862  
18863       ELSEIF(ISUB.EQ.25) THEN
18864 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18865         POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18866         POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18867         D34=P(IREF(IP,IORD),5)**2
18868         D56=P(IREF(IP,3-IORD),5)**2
18869         DT=PKK(1,3)+PKK(1,4)+D34
18870         DU=PKK(1,5)+PKK(1,6)+D56
18871         FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18872         CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18873         CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18874         CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18875         CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18876         FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18877      &  REAL(CBWW)*FGK(1,2,5,6,3,4))
18878         FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18879         IF(MSTP(50).LE.0) THEN
18880           WT=FGK135**2+(CCWW*FGK253)**2
18881           WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18882      &    CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18883      &    DJGK(DT,DU)))
18884         ELSE
18885           WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18886           WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18887      &    CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18888      &    POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18889         ENDIF
18890  
18891       ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18892 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18893 C...(or H0, or A0).
18894         WT=PKK(1,3)*PKK(2,4)
18895         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18896  
18897       ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18898 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18899 C...-> f + 2 quarks/leptons.
18900         CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18901      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18902      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18903         CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18904      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18905      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18906         CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18907      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18908      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18909         CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18910      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18911      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18912         IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18913      &  PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18914         IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18915      &  PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18916         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18917      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18918  
18919       ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18920 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18921         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18922         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18923         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18924  
18925       ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18926      &  ISUB.EQ.77) THEN
18927 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18928         WT=16D0*PKK(3,5)*PKK(4,6)
18929         WTMAX=SH**2
18930  
18931       ELSEIF(ISUB.EQ.110) THEN
18932 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18933         WT=1D0
18934         WTMAX=1D0
18935  
18936       ELSEIF(ISUB.EQ.141) THEN
18937 C...Special case: if only branching ratios known then isotropic decay.
18938         IF(MWID(32).EQ.2) THEN
18939           WT=1D0
18940           WTMAX=1D0
18941         ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN 
18942 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18943 C...Couplings of incoming flavour.
18944           KFAI=IABS(MINT(15))
18945           EI=KCHG(KFAI,1)/3D0
18946           AI=SIGN(1D0,EI+0.1D0)
18947           VI=AI-4D0*EI*XWV
18948           KFAIC=1
18949           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18950           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18951           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18952           IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18953             VPI=PARU(119+2*KFAIC)
18954             API=PARU(120+2*KFAIC)
18955           ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18956             VPI=PARJ(178+2*KFAIC)
18957             API=PARJ(179+2*KFAIC)
18958           ELSE
18959             VPI=PARJ(186+2*KFAIC)
18960             API=PARJ(187+2*KFAIC)
18961           ENDIF
18962 C...Couplings of final flavour.
18963           KFAF=IABS(KFL1(1))
18964           EF=KCHG(KFAF,1)/3D0
18965           AF=SIGN(1D0,EF+0.1D0)
18966           VF=AF-4D0*EF*XWV
18967           KFAFC=1
18968           IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18969           IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18970           IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18971           IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18972             VPF=PARU(119+2*KFAFC)
18973             APF=PARU(120+2*KFAFC)
18974           ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18975             VPF=PARJ(178+2*KFAFC)
18976             APF=PARJ(179+2*KFAFC)
18977           ELSE
18978             VPF=PARJ(186+2*KFAFC)
18979             APF=PARJ(187+2*KFAFC)
18980           ENDIF
18981 C...Asymmetry and weight.
18982           ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18983      &    4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18984      &    (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18985      &    (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18986      &    EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18987      &    (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18988      &    (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18989           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18990           WTMAX=2D0+ABS(ASYM)
18991         ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18992 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18993           RM1=P(NSD(1)+1,5)**2/SH
18994           RM2=P(NSD(1)+2,5)**2/SH
18995           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18996      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18997           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18998      &    (RM2-RM1)**2)
18999           WT=CFLAT+CCOS2*CTHE(1)**2
19000           WTMAX=CFLAT+MAX(0D0,CCOS2)
19001         ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
19002      &    IABS(KFL1(1)).EQ.37)) THEN
19003 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
19004           WT=1D0-CTHE(1)**2
19005           WTMAX=1D0
19006         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19007 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
19008           RM1=P(NSD(1)+1,5)**2/SH
19009           RM2=P(NSD(1)+2,5)**2/SH
19010           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19011           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19012           WTMAX=1D0+FLAM2/(8D0*RM1)
19013         ELSEIF(MZPWP.EQ.0) THEN
19014 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19015 C...(W:s like if intermediate Z).
19016           D34=P(IREF(IP,IORD),5)**2
19017           D56=P(IREF(IP,3-IORD),5)**2
19018           DT=PKK(1,3)+PKK(1,4)+D34
19019           DU=PKK(1,5)+PKK(1,6)+D56
19020           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19021           FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
19022           WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
19023           WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
19024      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19025         ELSEIF(MZPWP.EQ.1) THEN
19026 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19027 C...(W:s approximately longitudinal, like if intermediate H).
19028           WT=16D0*PKK(3,5)*PKK(4,6)
19029           WTMAX=SH**2
19030         ELSE
19031 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
19032 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
19033           WT=1D0
19034           WTMAX=1D0
19035         ENDIF
19036  
19037       ELSEIF(ISUB.EQ.142) THEN
19038 C...Special case: if only branching ratios known then isotropic decay.
19039         IF(MWID(34).EQ.2) THEN
19040           WT=1D0
19041           WTMAX=1D0
19042         ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN 
19043 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
19044           KFAI=IABS(MINT(15))
19045           KFAIC=1
19046           IF(KFAI.GT.10) KFAIC=2
19047           VI=PARU(129+2*KFAIC)
19048           AI=PARU(130+2*KFAIC)
19049           KFAF=IABS(KFL1(1))
19050           KFAFC=1
19051           IF(KFAF.GT.10) KFAFC=2
19052           VF=PARU(129+2*KFAFC)
19053           AF=PARU(130+2*KFAFC)
19054           ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
19055           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19056           WTMAX=2D0+ABS(ASYM)
19057         ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
19058 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
19059           RM1=P(NSD(1)+1,5)**2/SH
19060           RM2=P(NSD(1)+2,5)**2/SH
19061           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19062      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19063           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19064      &    (RM2-RM1)**2)
19065           WT=CFLAT+CCOS2*CTHE(1)**2
19066           WTMAX=CFLAT+MAX(0D0,CCOS2)
19067         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19068 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
19069           RM1=P(NSD(1)+1,5)**2/SH
19070           RM2=P(NSD(1)+2,5)**2/SH
19071           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19072           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19073           WTMAX=1D0+FLAM2/(8D0*RM1)
19074         ELSEIF(MZPWP.EQ.0) THEN
19075 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19076 C...(W/Z like if intermediate W).
19077           D34=P(IREF(IP,IORD),5)**2
19078           D56=P(IREF(IP,3-IORD),5)**2
19079           DT=PKK(1,3)+PKK(1,4)+D34
19080           DU=PKK(1,5)+PKK(1,6)+D56
19081           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19082           FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
19083           WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
19084           WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
19085      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19086         ELSEIF(MZPWP.EQ.1) THEN
19087 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19088 C...(W/Z approximately longitudinal, like if intermediate H).
19089           WT=16D0*PKK(3,5)*PKK(4,6)
19090           WTMAX=SH**2
19091         ELSE
19092 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
19093 C...t + bbar -> t + W + bbar.
19094           WT=1D0
19095           WTMAX=1D0
19096         ENDIF
19097  
19098       ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
19099      &  THEN
19100 C...Isotropic decay of leptoquarks (assumed spin 0).
19101         WT=1D0
19102         WTMAX=1D0
19103  
19104       ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
19105 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
19106         SIDE=1D0
19107         IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
19108         IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
19109           WT=1D0+SIDE*CTHE(1)
19110           WTMAX=2D0
19111         ELSEIF(IP.EQ.1) THEN
19112  
19113           RM1=P(NSD(1)+1,5)**2/SH
19114           WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19115           WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19116         ELSE
19117 C...W/Z decay assumed isotropic, since not known.
19118           WT=1D0
19119           WTMAX=1D0
19120         ENDIF
19121  
19122       ELSEIF(ISUB.EQ.149) THEN
19123 C...Isotropic decay of techni-eta.
19124         WT=1D0
19125         WTMAX=1D0
19126  
19127       ELSEIF(ISUB.EQ.191) THEN
19128         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19129 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
19130 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
19131           WT=1D0-CTHE(1)**2
19132           WTMAX=1D0
19133         ELSEIF(IP.EQ.1) THEN
19134 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
19135           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19136           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19137           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19138           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19139           KFAI=IABS(MINT(15))
19140           EI=KCHG(KFAI,1)/3D0
19141           AI=SIGN(1D0,EI+0.1D0)
19142           VI=AI-4D0*EI*XWV
19143           VALI=0.5D0*(VI+AI)
19144           VARI=0.5D0*(VI-AI)
19145           ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
19146           ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
19147           KFAF=IABS(KFL1(1))
19148           EF=KCHG(KFAF,1)/3D0
19149           AF=SIGN(1D0,EF+0.1D0)
19150           VF=AF-4D0*EF*XWV
19151           VALF=0.5D0*(VF+AF)
19152           VARF=0.5D0*(VF-AF)
19153           ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
19154           ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
19155           ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
19156           AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
19157           WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
19158           WTMAX=4D0*MAX(ASAME,AFLIP)
19159         ELSE
19160 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
19161           WT=1D0
19162           WTMAX=1D0
19163         ENDIF
19164  
19165       ELSEIF(ISUB.EQ.192) THEN
19166         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19167 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
19168 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
19169           WT=1D0-CTHE(1)**2
19170           WTMAX=1D0
19171         ELSEIF(IP.EQ.1) THEN
19172 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
19173           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19174           WT=(1D0+CTHESG)**2
19175           WTMAX=4D0
19176         ELSE
19177 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
19178           WT=1D0
19179           WTMAX=1D0
19180         ENDIF
19181  
19182       ELSEIF(ISUB.EQ.193) THEN
19183         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19184 C...Angular weight for f + fbar -> omega_tc0 ->
19185 C...gamma pi_tc0 or Z0 pi_tc0.
19186           WT=1D0+CTHE(1)**2
19187           WTMAX=2D0
19188         ELSEIF(IP.EQ.1) THEN
19189 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
19190           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19191           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19192           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19193           KFAI=IABS(MINT(15))
19194           EI=KCHG(KFAI,1)/3D0
19195           AI=SIGN(1D0,EI+0.1D0)
19196           VI=AI-4D0*EI*XWV
19197           VALI=0.5D0*(VI+AI)
19198           VARI=0.5D0*(VI-AI)
19199           BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
19200           BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
19201           KFAF=IABS(KFL1(1))
19202           EF=KCHG(KFAF,1)/3D0
19203           AF=SIGN(1D0,EF+0.1D0)
19204           VF=AF-4D0*EF*XWV
19205           VALF=0.5D0*(VF+AF)
19206           VARF=0.5D0*(VF-AF)
19207           BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
19208           BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
19209           BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
19210           BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
19211           WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
19212           WTMAX=4D0*MAX(BSAME,BFLIP)
19213         ELSE
19214 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
19215           WT=1D0
19216           WTMAX=1D0
19217         ENDIF
19218  
19219       ELSEIF(ISUB.EQ.353) THEN
19220 C...Angular weight for Z_R0 -> 2 quarks/leptons.
19221         EI=KCHG(IABS(MINT(15)),1)/3D0
19222         AI=SIGN(1D0,EI+0.1D0)
19223         VI=AI-4D0*EI*XWV
19224         EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
19225         AF=SIGN(1D0,EF+0.1D0)
19226         VF=AF-4D0*EF*XWV
19227         RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
19228         WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
19229         WT2=RMF*(VI**2+AI**2)*VF**2
19230         WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
19231         WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
19232      &  2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
19233         WTMAX=2D0*(WT1+ABS(WT3))
19234  
19235       ELSEIF(ISUB.EQ.354) THEN
19236 C...Angular weight for W_R+/- -> 2 quarks/leptons.
19237         RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
19238         RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
19239         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19240         WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
19241         WTMAX=4D0
19242  
19243       ELSEIF(ISUB.EQ.391) THEN
19244 C...Angular weight for f + fbar -> G* -> f + fbar
19245         IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19246           WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
19247           WTMAX=2D0
19248 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
19249 C...implemented by M.-C. Lemaire
19250         ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19251      &  IABS(KFL1(1)).EQ.22)) THEN
19252           WT=1D0-CTHE(1)**4
19253           WTMAX=1D0
19254 C...Other G* decays not yet implemented angular distributions.
19255         ELSE
19256           WT=1D0
19257           WTMAX=1D0
19258         ENDIF
19259  
19260       ELSEIF(ISUB.EQ.392) THEN
19261 C...Angular weight for g + g -> G* -> f + fbar
19262         IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19263           WT=1D0-CTHE(1)**4
19264           WTMAX=1D0
19265 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
19266 C...implemented by M.-C. Lemaire
19267         ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19268      &  IABS(KFL1(1)).EQ.22)) THEN
19269          WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
19270           WTMAX=8D0
19271 C...Other G* decays not yet implemented angular distributions.
19272         ELSE
19273           WT=1D0
19274           WTMAX=1D0
19275         ENDIF
19276  
19277 C...Obtain correct angular distribution by rejection techniques.
19278       ELSE
19279         WT=1D0
19280         WTMAX=1D0
19281       ENDIF
19282       IF(WT.LT.PYR(0)*WTMAX) GOTO 430
19283   
19284 C...Construct massive four-vectors using angles chosen.
19285   590 DO 690 JT=1,JTMAX
19286         IF(KDCY(JT).EQ.0) GOTO 690
19287         ID=IREF(IP,JT)
19288         DO 600 J=1,5
19289           DPMO(J)=P(ID,J)
19290   600   CONTINUE
19291         DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
19292 CMRENNA++
19293         NPROD=2
19294         IF(KFL3(JT).NE.0) NPROD=3
19295         IF(KFL4(JT).NE.0) NPROD=4
19296         CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
19297      &       DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
19298         N0=NSD(JT)+NPROD
19299  
19300         DO 610 J=1,4
19301           VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
19302   610   CONTINUE
19303 C...Fill in position of decay vertex.
19304         DO 630 I=NSD(JT)+1,N0
19305           DO 620 J=1,4
19306             V(I,J)=VDCY(J)
19307   620     CONTINUE
19308           V(I,5)=0D0
19309  
19310   630   CONTINUE
19311 CMRENNA--
19312  
19313 C...Mark decayed resonances; trace history.
19314         K(ID,1)=K(ID,1)+10
19315         KFA=IABS(K(ID,2))
19316         KCA=PYCOMP(KFA)
19317         IF(KCQM(JT).NE.0) THEN
19318 C...Do not kill colour flow through coloured resonance!
19319         ELSE
19320           K(ID,4)=NSD(JT)+1
19321           K(ID,5)=NSD(JT)+NPROD
19322           IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
19323 C...If 3-body or 2-body with junction:
19324 c          IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
19325 C...If 3-body with junction:
19326 c          IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
19327         ENDIF
19328  
19329 C...Add documentation lines.
19330         ISUBRG=MAX(1,MIN(500,MINT(1)))
19331         IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
19332           IDOC=MINT(83)+MINT(4)
19333 CMRENNA+++
19334           IHI=NSD(JT)+NPROD
19335 c          IF(KFL3(JT).NE.0) IHI=IHI+1
19336           DO 650 I=NSD(JT)+1,IHI
19337 CMRENNA---
19338             I1=MINT(83)+MINT(4)+1
19339             K(I,3)=I1
19340             IF(MSTP(128).GE.1) K(I,3)=ID
19341             IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
19342               MINT(4)=MINT(4)+1
19343               K(I1,1)=21
19344               K(I1,2)=K(I,2)
19345               K(I1,3)=IREF(IP,JT+3)
19346               DO 640 J=1,5
19347                 P(I1,J)=P(I,J)
19348   640         CONTINUE
19349             ENDIF
19350   650     CONTINUE
19351         ELSE
19352           K(NSD(JT)+1,3)=ID
19353           K(NSD(JT)+2,3)=ID
19354 C...If 3-body or 2-body with junction:
19355           IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
19356 C...If 3-body with junction:
19357           IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19358 C...If 4-body or 3-body with junction:
19359           IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19360 C...If 4-body with junction:
19361           IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID
19362         ENDIF
19363  
19364 C...Do showering of two or three objects.
19365         NSHBEF=N
19366         IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
19367           IF(KFL3(JT).EQ.0) THEN
19368             CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
19369           ELSE
19370             CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5))
19371           ENDIF
19372  
19373 c...For pT-ordered shower need set up first, especially colour tags.
19374 C...(Need to set up colour tags even if MSTP(71) = 0)
19375         ELSEIF(MINT(35).GE.2) THEN
19376           NPART=NPROD
19377 c          IF(KFL3(JT).NE.0) NPART=3
19378           IPART(1)=NSD(JT)+1
19379           IPART(2)=NSD(JT)+2
19380           IPART(3)=NSD(JT)+3
19381           IPART(4)=NSD(JT)+4
19382           PTPART(1)=0.5D0*P(ID,5)
19383           PTPART(2)=PTPART(1)
19384           PTPART(3)=PTPART(1)
19385           PTPART(4)=PTPART(1)
19386           IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
19387             MOTHER=K(NSD(JT)+1,4)/MSTU(5)
19388             IF(MOTHER.LE.NSD(JT)) THEN
19389               MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
19390             ELSE
19391               NCT=NCT+1
19392               MCT(NSD(JT)+1,1)=NCT
19393               MCT(MOTHER,2)=NCT
19394             ENDIF
19395           ENDIF
19396           IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
19397             MOTHER=K(NSD(JT)+1,5)/MSTU(5)
19398             IF(MOTHER.LE.NSD(JT)) THEN
19399               MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
19400             ELSE
19401               NCT=NCT+1
19402               MCT(NSD(JT)+1,2)=NCT
19403               MCT(MOTHER,1)=NCT
19404             ENDIF
19405           ENDIF
19406           IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
19407      &    KCQ2(JT).EQ.2)) THEN
19408             MOTHER=K(NSD(JT)+2,4)/MSTU(5)
19409             IF(MOTHER.LE.NSD(JT)) THEN
19410               MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
19411             ELSE
19412               NCT=NCT+1
19413               MCT(NSD(JT)+2,1)=NCT
19414               MCT(MOTHER,2)=NCT
19415             ENDIF
19416           ENDIF
19417           IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
19418      &    KCQ2(JT).EQ.2)) THEN
19419             MOTHER=K(NSD(JT)+2,5)/MSTU(5)
19420             IF(MOTHER.LE.NSD(JT)) THEN
19421               MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19422             ELSE
19423               NCT=NCT+1
19424               MCT(NSD(JT)+2,2)=NCT
19425               MCT(MOTHER,1)=NCT
19426             ENDIF
19427           ENDIF
19428           IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19429      &    (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19430             MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19431             MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19432           ENDIF
19433           IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19434      &    (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19435             MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19436             MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19437           ENDIF
19438           IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
19439      &    (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
19440             MOTHER=K(NSD(JT)+4,4)/MSTU(5)
19441             MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
19442           ENDIF
19443           IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
19444      &    (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
19445             MOTHER=K(NSD(JT)+4,5)/MSTU(5)
19446             MCT(NSD(JT)+4,2)=MCT(MOTHER,2)
19447           ENDIF
19448 
19449           IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19450         ENDIF
19451         NSHAFT=N
19452         IF(JT.EQ.1) NAFT1=N
19453  
19454 C...Check if decay products moved by shower.
19455         NSD1=NSD(JT)+1
19456         NSD2=NSD(JT)+2
19457         NSD3=NSD(JT)+3
19458         NSD4=NSD(JT)+4
19459 C...4-body decays will only work if one of the products is "inert"
19460         IF(NSHAFT.GT.NSHBEF) THEN
19461           IF(K(NSD1,1).GT.10) THEN
19462             DO 660 I=NSHBEF+1,NSHAFT
19463               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19464   660       CONTINUE
19465           ENDIF
19466           IF(K(NSD2,1).GT.10) THEN
19467             DO 670 I=NSHBEF+1,NSHAFT
19468               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19469      &        I.NE.NSD1) NSD2=I
19470   670       CONTINUE
19471           ENDIF
19472           IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19473             DO 680 I=NSHBEF+1,NSHAFT
19474               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19475      &        I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19476   680       CONTINUE
19477           ENDIF
19478           IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
19479             DO 685 I=NSHBEF+1,NSHAFT
19480               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
19481      &        I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
19482   685       CONTINUE
19483           ENDIF
19484         ENDIF
19485  
19486 C...Store decay products for further treatment.
19487         IF(KFL4(JT).EQ.0) THEN
19488           NP=NP+1
19489           IREF(NP,1)=NSD1
19490           IREF(NP,2)=NSD2
19491           IREF(NP,3)=0
19492           IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19493           IREF(NP,4)=IDOC+1
19494           IREF(NP,5)=IDOC+2
19495           IREF(NP,6)=0
19496           IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19497           IREF(NP,7)=K(IREF(IP,JT),2)
19498           IREF(NP,8)=IREF(IP,JT)
19499         ELSE
19500           NSDA=NSD1
19501           NSDB=NSD2
19502           NSDC=NSD3
19503           NP=NP+1
19504           IREF(NP,4)=IDOC+1
19505           IREF(NP,5)=IDOC+2
19506           IREF(NP,6)=IDOC+3
19507           IF(K(NSD1,1).EQ.1) THEN
19508             NSDA=NSD4
19509             IREF(NP,4)=IDOC+4
19510           ELSEIF(K(NSD2,1).EQ.1) THEN
19511             NSDB=NSD4
19512             IREF(NP,5)=IDOC+4
19513           ELSEIF(K(NSD3,1).EQ.1) THEN
19514             NSDC=NSD4
19515             IREF(NP,6)=IDOC+4
19516           ENDIF
19517           IREF(NP,1)=NSDA
19518           IREF(NP,2)=NSDB
19519           IREF(NP,3)=NSDC
19520           IREF(NP,7)=K(IREF(IP,JT),2)
19521           IREF(NP,8)=IREF(IP,JT)
19522         ENDIF
19523   690 CONTINUE
19524  
19525  
19526 C...Fill information for 2 -> 1 -> 2.
19527   700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19528         MINT(7)=MINT(83)+6+2*ISET(ISUB)
19529         MINT(8)=MINT(83)+7+2*ISET(ISUB)
19530         MINT(25)=KFL1(1)
19531         MINT(26)=KFL2(1)
19532         VINT(23)=CTHE(1)
19533         RM3=P(N-1,5)**2/SH
19534         RM4=P(N,5)**2/SH
19535         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19536         VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19537         VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19538         VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19539         VINT(47)=SQRT(VINT(48))
19540       ENDIF
19541  
19542 C...Possibility of colour rearrangement in W+W- events.
19543       IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19544         IAKF1=IABS(KFL1(1))
19545         IAKF2=IABS(KFL1(2))
19546         IAKF3=IABS(KFL2(1))
19547         IAKF4=IABS(KFL2(2))
19548         IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19549      &  MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19550      &  PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19551         IF(MINT(51).NE.0) RETURN
19552       ENDIF
19553 
19554 C...Loop back if needed.
19555   710 IF(IP.LT.NP) GOTO 170
19556 
19557 C...Boost back to standard frame.
19558   720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19559      &BEZIN)
19560 
19561  
19562       RETURN
19563       END
19564  
19565 C*********************************************************************
19566  
19567 C...PYMULT
19568 C...Initializes treatment of multiple interactions, selects kinematics
19569 C...of hardest interaction if low-pT physics included in run, and
19570 C...generates all non-hardest interactions.
19571  
19572       SUBROUTINE PYMULT(MMUL)
19573  
19574 C...Double precision and integer declarations.
19575       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19576       IMPLICIT INTEGER(I-N)
19577       INTEGER PYK,PYCHGE,PYCOMP
19578 C...Commonblocks.
19579       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19580       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19581       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19582       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19583       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19584       COMMON/PYINT1/MINT(400),VINT(400)
19585       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19586       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19587       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19588       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19589       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19590      &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19591 C...Local arrays and saved variables.
19592       DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19593       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19594      &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19595      &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19596  
19597 C...Initialization of multiple interaction treatment.
19598       IF(MMUL.EQ.1) THEN
19599         IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19600         ISUB=96
19601         MINT(1)=96
19602         VINT(63)=0D0
19603         VINT(64)=0D0
19604         VINT(143)=1D0
19605         VINT(144)=1D0
19606  
19607 C...Loop over phase space points: xT2 choice in 20 bins.
19608   100   SIGSUM=0D0
19609         DO 120 IXT2=1,20
19610           NMUL(IXT2)=MSTP(83)
19611           SIGM(IXT2)=0D0
19612           DO 110 ITRY=1,MSTP(83)
19613             RSCA=0.05D0*((21-IXT2)-PYR(0))
19614             XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19615             XT2=MAX(0.01D0*VINT(149),XT2)
19616             VINT(25)=XT2
19617  
19618 C...Choose tau and y*. Calculate cos(theta-hat).
19619             IF(PYR(0).LE.COEF(ISUB,1)) THEN
19620               TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19621               TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19622             ELSE
19623               TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19624             ENDIF
19625             VINT(21)=TAU
19626             CALL PYKLIM(2)
19627             RYST=PYR(0)
19628             MYST=1
19629             IF(RYST.GT.COEF(ISUB,8)) MYST=2
19630             IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19631             CALL PYKMAP(2,MYST,PYR(0))
19632             VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19633  
19634 C...Calculate differential cross-section.
19635             VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19636             CALL PYSIGH(NCHN,SIGS)
19637             SIGM(IXT2)=SIGM(IXT2)+SIGS
19638   110     CONTINUE
19639           SIGSUM=SIGSUM+SIGM(IXT2)
19640   120   CONTINUE
19641         SIGSUM=SIGSUM/(20D0*MSTP(83))
19642  
19643 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19644         IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19645           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19646      &    PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19647           PARP(82)=0.9D0*PARP(82)
19648           VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19649      &    VINT(2)
19650           GOTO 100
19651         ENDIF
19652         IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19653      &  PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19654  
19655 C...Start iteration to find k factor.
19656         YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19657         P83A=(1D0-PARP(83))**2
19658         P83B=2D0*PARP(83)*(1D0-PARP(83))
19659         P83C=PARP(83)**2
19660         CQ2I=1D0/PARP(84)**2
19661         CQ2R=2D0/(1D0+PARP(84)**2)
19662         SO=0.5D0
19663         XI=0D0
19664         YI=0D0
19665         XF=0D0
19666         YF=0D0
19667         XK=0.5D0
19668         IIT=0
19669   130   IF(IIT.EQ.0) THEN
19670           XK=2D0*XK
19671         ELSEIF(IIT.EQ.1) THEN
19672           XK=0.5D0*XK
19673         ELSE
19674           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19675         ENDIF
19676  
19677 C...Evaluate overlap integrals. Find where to divide the b range.
19678         IF(MSTP(82).EQ.2) THEN
19679           SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19680           SOP=SP/PARU(1)
19681         ELSE
19682           IF(MSTP(82).EQ.3) THEN
19683             DELTAB=0.02D0
19684           ELSEIF(MSTP(82).EQ.4) THEN
19685             DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19686           ELSE
19687             POWIP=MAX(0.4D0,PARP(83))
19688             RPWIP=2D0/POWIP-1D0
19689             DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19690             SO=0D0
19691           ENDIF
19692           SP=0D0
19693           SOP=0D0
19694           BSP=0D0
19695           SOHIGH=0D0
19696           IBDIV=0
19697           B=-0.5D0*DELTAB
19698   140     B=B+DELTAB
19699           IF(MSTP(82).EQ.3) THEN
19700             OV=EXP(-B**2)/PARU(2)
19701           ELSEIF(MSTP(82).EQ.4) THEN
19702             OV=(P83A*EXP(-MIN(50D0,B**2))+
19703      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19704      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19705           ELSE
19706             OV=EXP(-B**POWIP)/PARU(2)
19707             SO=SO+PARU(2)*B*DELTAB*OV
19708           ENDIF
19709           IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19710           PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19711           SP=SP+PARU(2)*B*DELTAB*PACC
19712           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19713           BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19714           IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19715             IBDIV=1 
19716             BDIV=B+0.5D0*DELTAB
19717           ENDIF
19718           IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19719         ENDIF
19720         YK=PARU(1)*XK*SO/SP
19721  
19722 C...Continue iteration until convergence.
19723         IF(YK.LT.YKE) THEN
19724           XI=XK
19725           YI=YK
19726           IF(IIT.EQ.1) IIT=2
19727         ELSE
19728           XF=XK
19729           YF=YK
19730           IF(IIT.EQ.0) IIT=1
19731         ENDIF
19732         IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19733  
19734 C...Store some results for subsequent use.
19735         BAVG=BSP/SP
19736         VINT(145)=SIGSUM
19737         VINT(146)=SOP/SO
19738         VINT(147)=SOP/SP
19739         VNT145=VINT(145)
19740         VNT146=VINT(146)
19741         VNT147=VINT(147)
19742 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19743         PIK=(VNT146/VNT147)*YKE
19744 
19745 C...Find relative weight for low and high impact parameter.
19746       PLOWB=PARU(1)*BDIV**2
19747       IF(MSTP(82).EQ.3) THEN
19748         PHIGHB=PIK*0.5*EXP(-BDIV**2)
19749       ELSEIF(MSTP(82).EQ.4) THEN
19750         S4A=P83A*EXP(-BDIV**2)
19751         S4B=P83B*EXP(-BDIV**2*CQ2R)
19752         S4C=P83C*EXP(-BDIV**2*CQ2I)
19753         PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19754       ELSEIF(PARP(83).GE.1.999D0) THEN
19755         PHIGHB=PIK*SOHIGH
19756         B2RPDV=BDIV**POWIP
19757       ELSE
19758         PHIGHB=PIK*SOHIGH
19759         B2RPDV=BDIV**POWIP
19760         B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19761       ENDIF 
19762       PALLB=PLOWB+PHIGHB
19763  
19764 C...Initialize iteration in xT2 for hardest interaction.
19765       ELSEIF(MMUL.EQ.2) THEN
19766         VINT(145)=VNT145
19767         VINT(146)=VNT146
19768         VINT(147)=VNT147
19769         IF(MSTP(82).LE.0) THEN
19770         ELSEIF(MSTP(82).EQ.1) THEN
19771           XT2=1D0
19772           SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19773           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19774      &    VINT(317)/(VINT(318)*VINT(320))
19775           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19776         ELSEIF(MSTP(82).EQ.2) THEN
19777           XT2=1D0
19778           XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19779      &    VINT(149)*(1D0+VINT(149))
19780         ELSE
19781           XC2=4D0*CKIN(3)**2/VINT(2)
19782           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19783         ENDIF
19784 
19785 C...Select impact parameter for hardest interaction.
19786         IF(MSTP(82).LE.2) RETURN
19787   142   IF(PYR(0)*PALLB.LT.PLOWB) THEN
19788 C...Treatment in low b region.
19789           MINT(39)=1
19790           B=BDIV*SQRT(PYR(0)) 
19791           IF(MSTP(82).EQ.3) THEN
19792             OV=EXP(-B**2)/PARU(2)
19793           ELSEIF(MSTP(82).EQ.4) THEN
19794             OV=(P83A*EXP(-MIN(50D0,B**2))+
19795      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19796      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19797           ELSE
19798             OV=EXP(-B**POWIP)/PARU(2)
19799           ENDIF  
19800           VINT(148)=OV/VNT147
19801           PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19802           XT2=1D0
19803           XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19804      &    VINT(149)*(1D0+VINT(149))
19805         ELSE
19806 C...Treatment in high b region.
19807           MINT(39)=2
19808           IF(MSTP(82).EQ.3) THEN
19809             B=SQRT(BDIV**2-LOG(PYR(0)))
19810             OV=EXP(-B**2)/PARU(2)
19811           ELSEIF(MSTP(82).EQ.4) THEN
19812             S4RNDM=PYR(0)*(S4A+S4B+S4C)
19813             IF(S4RNDM.LT.S4A) THEN
19814               B=SQRT(BDIV**2-LOG(PYR(0)))
19815             ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19816               B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19817             ELSE
19818               B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19819             ENDIF    
19820             OV=(P83A*EXP(-MIN(50D0,B**2))+
19821      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19822      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19823           ELSEIF(PARP(83).GE.1.999D0) THEN
19824   144       B2RPW=B2RPDV-LOG(PYR(0))
19825             ACCIP=(B2RPW/B2RPDV)**RPWIP
19826             IF(ACCIP.LT.PYR(0)) GOTO 144
19827             OV=EXP(-B2RPW)/PARU(2)
19828             B=B2RPW**(1D0/POWIP)
19829           ELSE
19830   146       B2RPW=B2RPDV-2D0*LOG(PYR(0))
19831             ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19832             IF(ACCIP.LT.PYR(0)) GOTO 146
19833             OV=EXP(-B2RPW)/PARU(2)
19834             B=B2RPW**(1D0/POWIP)
19835           ENDIF  
19836           VINT(148)=OV/VNT147
19837           PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19838         ENDIF
19839         IF(PACC.LT.PYR(0)) GOTO 142
19840         VINT(139)=B/BAVG
19841  
19842       ELSEIF(MMUL.EQ.3) THEN
19843 C...Low-pT or multiple interactions (first semihard interaction):
19844 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19845 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19846         ISUB=MINT(1)
19847         VINT(145)=VNT145
19848         VINT(146)=VNT146
19849         VINT(147)=VNT147
19850         IF(MSTP(82).LE.0) THEN
19851           XT2=0D0
19852         ELSEIF(MSTP(82).EQ.1) THEN
19853           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19854 C...Use with "Sudakov" for low b values when impact parameter dependence.
19855         ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19856           IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19857      &    VINT(149)))).GT.PYR(0)) XT2=1D0
19858           IF(XT2.GE.1D0) THEN
19859             XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19860      &      PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19861      &      VINT(149)
19862           ELSE
19863             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19864      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19865      &      VINT(149)
19866           ENDIF
19867           XT2=MAX(0.01D0*VINT(149),XT2)
19868 C...Use without "Sudakov" for high b values when impact parameter dep.
19869         ELSE
19870           XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19871      &    PYR(0)*(1D0-XC2))-VINT(149)
19872           XT2=MAX(0.01D0*VINT(149),XT2)
19873         ENDIF
19874         VINT(25)=XT2
19875  
19876 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19877         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19878           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19879           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19880           ISUB=95
19881           MINT(1)=ISUB
19882           VINT(21)=0.01D0*VINT(149)
19883           VINT(22)=0D0
19884           VINT(23)=0D0
19885           VINT(25)=0.01D0*VINT(149)
19886  
19887         ELSE
19888 C...Multiple interactions (first semihard interaction).
19889 C...Choose tau and y*. Calculate cos(theta-hat).
19890           IF(PYR(0).LE.COEF(ISUB,1)) THEN
19891             TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19892             TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19893           ELSE
19894             TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19895           ENDIF
19896           VINT(21)=TAU
19897           CALL PYKLIM(2)
19898           RYST=PYR(0)
19899           MYST=1
19900           IF(RYST.GT.COEF(ISUB,8)) MYST=2
19901           IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19902           CALL PYKMAP(2,MYST,PYR(0))
19903           VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19904         ENDIF
19905         VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19906  
19907 C...Store results of cross-section calculation.
19908       ELSEIF(MMUL.EQ.4) THEN
19909         ISUB=MINT(1)
19910         VINT(145)=VNT145
19911         VINT(146)=VNT146
19912         VINT(147)=VNT147
19913         XTS=VINT(25)
19914         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19915         IF(ISET(ISUB).EQ.2)
19916      &  XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19917         IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19918         RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19919      &  (XTS+VINT(149))))
19920         IRBIN=INT(1D0+20D0*RBIN)
19921         IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19922           NMUL(IRBIN)=NMUL(IRBIN)+1
19923           SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19924         ENDIF
19925  
19926 C...Choose impact parameter if not already done.
19927       ELSEIF(MMUL.EQ.5) THEN
19928         ISUB=MINT(1)
19929         VINT(145)=VNT145
19930         VINT(146)=VNT146
19931         VINT(147)=VNT147
19932   150   IF(MINT(39).GT.0) THEN
19933         ELSEIF(MSTP(82).EQ.3) THEN
19934           EXPB2=PYR(0)
19935           B2=-LOG(PYR(0))
19936           VINT(148)=EXPB2/(PARU(2)*VNT147)
19937           VINT(139)=SQRT(B2)/BAVG
19938         ELSEIF(MSTP(82).EQ.4) THEN
19939           RTYPE=PYR(0)
19940           IF(RTYPE.LT.P83A) THEN
19941             B2=-LOG(PYR(0))
19942           ELSEIF(RTYPE.LT.P83A+P83B) THEN
19943             B2=-LOG(PYR(0))/CQ2R
19944           ELSE
19945             B2=-LOG(PYR(0))/CQ2I
19946           ENDIF
19947           VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19948      &    P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19949      &    P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19950           VINT(139)=SQRT(B2)/BAVG
19951         ELSEIF(PARP(83).GE.1.999D0) THEN
19952           POWIP=MAX(2D0,PARP(83))
19953           RPWIP=2D0/POWIP-1D0
19954           PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19955   160     IF(PYR(0).LT.PROB1) THEN
19956             B2RPW=PYR(0)**(0.5D0*POWIP)
19957             ACCIP=EXP(-B2RPW)
19958           ELSE
19959             B2RPW=1D0-LOG(PYR(0))
19960             ACCIP=B2RPW**RPWIP
19961           ENDIF
19962           IF(ACCIP.LT.PYR(0)) GOTO 160
19963           VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19964           VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19965         ELSE
19966           POWIP=MAX(0.4D0,PARP(83))
19967           RPWIP=2D0/POWIP-1D0
19968           PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19969   170     IF(PYR(0).LT.PROB1) THEN
19970             B2RPW=2D0*RPWIP*PYR(0)
19971             ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19972           ELSE
19973             B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19974             ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19975           ENDIF
19976           IF(ACCIP.LT .PYR(0)) GOTO 170
19977           VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19978           VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19979         ENDIF
19980  
19981 C...Multiple interactions (variable impact parameter) : reject with
19982 C...probability exp(-overlap*cross-section above pT/normalization).
19983 C...Does not apply to low-b region, where "Sudakov" already included.
19984         VINT(150)=1D0 
19985         IF(MINT(39).NE.1) THEN
19986           RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19987           SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19988           DO 180 IBIN=IRBIN+1,20
19989             RNCOR=RNCOR+NMUL(IBIN)
19990             SIGCOR=SIGCOR+SIGM(IBIN)
19991   180     CONTINUE
19992           SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19993           IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19994           VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19995      &    SIGABV/MAX(1D-10,SIGT(0,0,5))))
19996         ENDIF
19997         IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19998      &  ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19999      &  .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20000           IF(VINT(150).LT.PYR(0)) GOTO 150
20001           VINT(150)=1D0
20002         ENDIF
20003  
20004 C...Generate additional multiple semihard interactions.
20005       ELSEIF(MMUL.EQ.6) THEN
20006         ISUBSV=MINT(1)
20007         VINT(145)=VNT145
20008         VINT(146)=VNT146
20009         VINT(147)=VNT147
20010         DO 190 J=11,80
20011           VINTSV(J)=VINT(J)
20012   190   CONTINUE
20013         ISUB=96
20014         MINT(1)=96
20015         VINT(151)=0D0
20016         VINT(152)=0D0
20017  
20018 C...Reconstruct strings in hard scattering.
20019         NMAX=MINT(84)+4
20020         IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
20021         IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
20022         NSTR=0
20023         DO 210 I=MINT(84)+1,NMAX
20024           KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
20025           IF(KCS.EQ.0) GOTO 210
20026           DO 200 J=1,4
20027             IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
20028             IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
20029             IF(J.LE.2) THEN
20030               IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
20031             ELSE
20032               IST=MOD(K(I,J+1),MSTU(5))
20033             ENDIF
20034             IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
20035             IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
20036             NSTR=NSTR+1
20037             IF(J.EQ.1.OR.J.EQ.4) THEN
20038               KSTR(NSTR,1)=I
20039               KSTR(NSTR,2)=IST
20040             ELSE
20041               KSTR(NSTR,1)=IST
20042               KSTR(NSTR,2)=I
20043             ENDIF
20044   200     CONTINUE
20045   210   CONTINUE
20046  
20047 C...Set up starting values for iteration in xT2.
20048         XT2=4D0*VINT(62)/VINT(2)
20049         IF(MSTP(82).LE.1) THEN
20050           SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20051           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20052      &    VINT(317)/(VINT(318)*VINT(320))
20053           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20054         ELSE
20055           XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20056      &    MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20057         ENDIF
20058         VINT(63)=0D0
20059         VINT(64)=0D0
20060         VINT(143)=1D0-VINT(141)
20061         VINT(144)=1D0-VINT(142)
20062  
20063 C...Iterate downwards in xT2.
20064   220   IF(MSTP(82).LE.1) THEN
20065           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20066           IF(XT2.LT.VINT(149)) GOTO 270
20067         ELSE
20068           IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
20069           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20070      &    LOG(PYR(0)))-VINT(149)
20071           IF(XT2.LE.0D0) GOTO 270
20072           XT2=MAX(0.01D0*VINT(149),XT2)
20073         ENDIF
20074         VINT(25)=XT2
20075  
20076 C...Choose tau and y*. Calculate cos(theta-hat).
20077         IF(PYR(0).LE.COEF(ISUB,1)) THEN
20078           TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20079           TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20080         ELSE
20081           TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20082         ENDIF
20083         VINT(21)=TAU
20084         CALL PYKLIM(2)
20085         RYST=PYR(0)
20086         MYST=1
20087         IF(RYST.GT.COEF(ISUB,8)) MYST=2
20088         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20089         CALL PYKMAP(2,MYST,PYR(0))
20090         VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20091  
20092 C...Check that x not used up. Accept or reject kinematical variables.
20093         X1M=SQRT(TAU)*EXP(VINT(22))
20094         X2M=SQRT(TAU)*EXP(-VINT(22))
20095         IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
20096         VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20097         CALL PYSIGH(NCHN,SIGS)
20098         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20099         IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
20100  
20101 C...Reset K, P and V vectors. Select some variables.
20102         DO 240 I=N+1,N+2
20103           DO 230 J=1,5
20104             K(I,J)=0
20105             P(I,J)=0D0
20106             V(I,J)=0D0
20107   230     CONTINUE
20108   240   CONTINUE
20109         RFLAV=PYR(0)
20110         PT=0.5D0*VINT(1)*SQRT(XT2)
20111         PHI=PARU(2)*PYR(0)
20112         CTH=VINT(23)
20113  
20114 C...Add first parton to event record.
20115         K(N+1,1)=3
20116         K(N+1,2)=21
20117         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
20118      &  1+INT((2D0+PARJ(2))*PYR(0))
20119         P(N+1,1)=PT*COS(PHI)
20120         P(N+1,2)=PT*SIN(PHI)
20121         P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
20122         P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
20123         P(N+1,5)=0D0
20124  
20125 C...Add second parton to event record.
20126         K(N+2,1)=3
20127         K(N+2,2)=21
20128         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
20129         P(N+2,1)=-P(N+1,1)
20130         P(N+2,2)=-P(N+1,2)
20131         P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
20132         P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
20133         P(N+2,5)=0D0
20134  
20135         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
20136 C....Choose relevant string pieces to place gluons on.
20137           DO 260 I=N+1,N+2
20138             DMIN=1D8
20139             DO 250 ISTR=1,NSTR
20140               I1=KSTR(ISTR,1)
20141               I2=KSTR(ISTR,2)
20142               DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
20143      &        P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
20144      &        P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
20145      &        P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
20146               IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
20147                 DMIN=DIST
20148                 IST1=I1
20149                 IST2=I2
20150                 ISTM=ISTR
20151               ENDIF
20152   250       CONTINUE
20153  
20154 C....Colour flow adjustments, new string pieces.
20155             IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
20156      &      MOD(K(IST1,4),MSTU(5))
20157             IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
20158      &      MSTU(5)*(K(IST1,5)/MSTU(5))+I
20159             K(I,5)=MSTU(5)*IST1
20160             K(I,4)=MSTU(5)*IST2
20161             IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
20162      &      MOD(K(IST2,5),MSTU(5))
20163             IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
20164      &      MSTU(5)*(K(IST2,4)/MSTU(5))+I
20165             KSTR(ISTM,2)=I
20166             KSTR(NSTR+1,1)=I
20167             KSTR(NSTR+1,2)=IST2
20168             NSTR=NSTR+1
20169   260     CONTINUE
20170  
20171 C...String drawing and colour flow for gluon loop.
20172         ELSEIF(K(N+1,2).EQ.21) THEN
20173           K(N+1,4)=MSTU(5)*(N+2)
20174           K(N+1,5)=MSTU(5)*(N+2)
20175           K(N+2,4)=MSTU(5)*(N+1)
20176           K(N+2,5)=MSTU(5)*(N+1)
20177           KSTR(NSTR+1,1)=N+1
20178           KSTR(NSTR+1,2)=N+2
20179           KSTR(NSTR+2,1)=N+2
20180           KSTR(NSTR+2,2)=N+1
20181           NSTR=NSTR+2
20182  
20183 C...String drawing and colour flow for qqbar pair.
20184         ELSE
20185           K(N+1,4)=MSTU(5)*(N+2)
20186           K(N+2,5)=MSTU(5)*(N+1)
20187           KSTR(NSTR+1,1)=N+1
20188           KSTR(NSTR+1,2)=N+2
20189           NSTR=NSTR+1
20190         ENDIF
20191  
20192 C...Global statistics.
20193         MINT(351)=MINT(351)+1
20194         VINT(351)=VINT(351)+PT
20195         IF (MINT(351).EQ.1) VINT(356)=PT
20196  
20197 C...Update remaining energy; iterate.
20198         N=N+2
20199         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20200           CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
20201           MINT(51)=1
20202           RETURN
20203         ENDIF
20204         MINT(31)=MINT(31)+1
20205         VINT(151)=VINT(151)+VINT(41)
20206         VINT(152)=VINT(152)+VINT(42)
20207         VINT(143)=VINT(143)-VINT(41)
20208         VINT(144)=VINT(144)-VINT(42)
20209 C...Allow FSR for UE (always handle with old showers)
20210         IF(MSTP(152).EQ.1) THEN
20211           M41SAV=MSTJ(41)
20212           IF (MSTJ(41).EQ.10) MSTJ(41)=2
20213           MSTJ(41)=MOD(MSTJ(41),10)
20214           CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
20215           MSTJ(41)=M41SAV
20216         ENDIF
20217         IF(MINT(31).LT.240) GOTO 220
20218   270   CONTINUE
20219         MINT(1)=ISUBSV
20220         DO 280 J=11,80
20221           VINT(J)=VINTSV(J)
20222   280   CONTINUE
20223       ENDIF
20224  
20225 C...Format statements for printout.
20226  5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
20227      &'actions for MSTP(82) =',I2,' ******')
20228  5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20229      &D9.2,' mb: rejected')
20230  5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20231      &D9.2,' mb: accepted')
20232  
20233       RETURN
20234       END
20235  
20236 C*********************************************************************
20237  
20238 C...PYREMN
20239 C...Adds on target remnants (one or two from each side) and
20240 C...includes primordial kT for hadron beams.
20241  
20242       SUBROUTINE PYREMN(IPU1,IPU2)
20243  
20244 C...Double precision and integer declarations.
20245       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20246       IMPLICIT INTEGER(I-N)
20247       INTEGER PYK,PYCHGE,PYCOMP
20248 C...Commonblocks.
20249       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20250       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20251       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20252       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20253       COMMON/PYINT1/MINT(400),VINT(400)
20254       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
20255 C...Local arrays.
20256       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
20257      &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
20258  
20259 C...Find event type and remaining energy.
20260       ISUB=MINT(1)
20261       NS=N
20262       IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
20263         VINT(143)=1D0-VINT(141)
20264         VINT(144)=1D0-VINT(142)
20265       ENDIF
20266  
20267 C...Define initial partons.
20268       NTRY=0
20269   100 NTRY=NTRY+1
20270       DO 130 JT=1,2
20271         I=MINT(83)+JT+2
20272         IF(JT.EQ.1) IPU=IPU1
20273         IF(JT.EQ.2) IPU=IPU2
20274         K(I,1)=21
20275         K(I,2)=K(IPU,2)
20276         K(I,3)=I-2
20277         PMS(JT)=0D0
20278         VINT(156+JT)=0D0
20279         VINT(158+JT)=0D0
20280         IF(MINT(47).EQ.1) THEN
20281           DO 110 J=1,5
20282             P(I,J)=P(I-2,J)
20283   110     CONTINUE
20284         ELSEIF(ISUB.EQ.95) THEN
20285           K(I,2)=21
20286         ELSE
20287           P(I,5)=P(IPU,5)
20288  
20289 C...No primordial kT, or chosen according to truncated Gaussian or
20290 C...exponential, or (for photon) predetermined or power law.
20291   120     IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
20292             IF(MSTP(91).LE.0) THEN
20293               PT=0D0
20294             ELSEIF(MSTP(91).EQ.1) THEN
20295               PT=PARP(91)*SQRT(-LOG(PYR(0)))
20296             ELSE
20297               RPT1=PYR(0)
20298               RPT2=PYR(0)
20299               PT=-PARP(92)*LOG(RPT1*RPT2)
20300             ENDIF
20301             IF(PT.GT.PARP(93)) GOTO 120
20302           ELSEIF(MINT(106+JT).EQ.3) THEN
20303             PTA=SQRT(VINT(282+JT))
20304             PTB=0D0
20305             IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
20306               PTB=PARP(99)*SQRT(-LOG(PYR(0)))
20307             ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
20308               RPT1=PYR(0)
20309               RPT2=PYR(0)
20310               PTB=-PARP(99)*LOG(RPT1*RPT2)
20311             ENDIF
20312             IF(PTB.GT.PARP(100)) GOTO 120
20313             PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
20314             PT=PT*0.8D0**MINT(57)
20315             IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
20316           ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
20317             IF(MSTP(93).LE.0) THEN
20318               PT=0D0
20319             ELSEIF(MSTP(93).EQ.1) THEN
20320               PT=PARP(99)*SQRT(-LOG(PYR(0)))
20321             ELSEIF(MSTP(93).EQ.2) THEN
20322               RPT1=PYR(0)
20323               RPT2=PYR(0)
20324               PT=-PARP(99)*LOG(RPT1*RPT2)
20325             ELSEIF(MSTP(93).EQ.3) THEN
20326               HA=PARP(99)**2
20327               HB=PARP(100)**2
20328               PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
20329             ELSE
20330               HA=PARP(99)**2
20331               HB=PARP(100)**2
20332               IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
20333               PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
20334             ENDIF
20335             IF(PT.GT.PARP(100)) GOTO 120
20336           ELSE
20337             PT=0D0
20338           ENDIF
20339           VINT(156+JT)=PT
20340           PHI=PARU(2)*PYR(0)
20341           P(I,1)=PT*COS(PHI)
20342           P(I,2)=PT*SIN(PHI)
20343           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20344         ENDIF
20345   130 CONTINUE
20346       IF(MINT(47).EQ.1) RETURN
20347  
20348 C...Kinematics construction for initial partons.
20349       I1=MINT(83)+3
20350       I2=MINT(83)+4
20351       IF(ISUB.EQ.95) THEN
20352         SHS=0D0
20353         SHR=0D0
20354       ELSE
20355         SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
20356      &  (P(I1,2)+P(I2,2))**2
20357         SHR=SQRT(MAX(0D0,SHS))
20358         IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
20359         P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
20360         P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
20361         P(I2,4)=SHR-P(I1,4)
20362         P(I2,3)=-P(I1,3)
20363  
20364 C...Transform partons to overall CM-frame.
20365         ROBO(3)=(P(I1,1)+P(I2,1))/SHR
20366         ROBO(4)=(P(I1,2)+P(I2,2))/SHR
20367         CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
20368         ROBO(2)=PYANGL(P(I1,1),P(I1,2))
20369         CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
20370         ROBO(1)=PYANGL(P(I1,3),P(I1,1))
20371         CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
20372         CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
20373         CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
20374         ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
20375         CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
20376       ENDIF
20377  
20378 C...Optionally fix up x and Q2 definitions for leptoproduction.
20379       IDISXQ=0
20380       IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
20381      &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
20382       IF(IDISXQ.EQ.1) THEN
20383  
20384 C...Find where incoming and outgoing leptons/partons are sitting.
20385         LESD=1
20386         IF(MINT(42).EQ.1) LESD=2
20387         LPIN=MINT(83)+3-LESD
20388         LEIN=MINT(84)+LESD
20389         LQIN=MINT(84)+3-LESD
20390         LEOUT=MINT(84)+2+LESD
20391         LQOUT=MINT(84)+5-LESD
20392         IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
20393         IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
20394         LSCMS=0
20395         DO 140 I=MINT(84)+5,N
20396           IF(K(I,2).EQ.94) THEN
20397             LSCMS=I
20398             LEOUT=I+LESD
20399             LQOUT=I+3-LESD
20400           ENDIF
20401   140   CONTINUE
20402         LQBG=IPU1
20403         IF(LESD.EQ.1) LQBG=IPU2
20404  
20405 C...Calculate actual and wanted momentum transfer.
20406         XNOM=VINT(43-LESD)
20407         Q2NOM=-VINT(45)
20408         HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
20409      &  P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
20410      &  (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
20411         HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
20412         FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
20413         P(N+1,1)=FAC*P(LEOUT,1)
20414         P(N+1,2)=FAC*P(LEOUT,2)
20415         P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
20416      &  Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
20417         P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
20418      &  P(N+1,3)**2)
20419         DO 150 J=1,4
20420           QOLD(J)=P(LEIN,J)-P(LEOUT,J)
20421           QNEW(J)=P(LEIN,J)-P(N+1,J)
20422   150   CONTINUE
20423  
20424 C...Boost outgoing electron and daughters.
20425         IF(LSCMS.EQ.0) THEN
20426           DO 160 J=1,4
20427             P(LEOUT,J)=P(N+1,J)
20428   160     CONTINUE
20429         ELSE
20430           DO 170 J=1,3
20431             P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
20432   170     CONTINUE
20433           PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
20434           DO 180 J=1,3
20435             DBE(J)=PINV*P(N+2,J)
20436   180     CONTINUE
20437           DO 200 I=LSCMS+1,N
20438             IORIG=I
20439   190       IORIG=K(IORIG,3)
20440             IF(IORIG.GT.LEOUT) GOTO 190
20441             IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
20442      &      CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
20443   200     CONTINUE
20444         ENDIF
20445  
20446 C...Copy shower initiator and all outgoing partons.
20447         NCOP=N+1
20448         K(NCOP,3)=LQBG
20449         DO 210 J=1,5
20450           P(NCOP,J)=P(LQBG,J)
20451   210   CONTINUE
20452         DO 240 I=MINT(84)+1,N
20453           ICOP=0
20454           IF(K(I,1).GT.10) GOTO 240
20455           IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
20456             ICOP=I
20457           ELSE
20458             IORIG=I
20459   220       IORIG=K(IORIG,3)
20460             IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
20461               ICOP=IORIG
20462             ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
20463               GOTO 220
20464             ENDIF
20465           ENDIF
20466           IF(ICOP.NE.0) THEN
20467             NCOP=NCOP+1
20468             K(NCOP,3)=I
20469             DO 230 J=1,5
20470               P(NCOP,J)=P(I,J)
20471   230       CONTINUE
20472           ENDIF
20473   240   CONTINUE
20474  
20475 C...Calculate relative rescaling factors.
20476         SLC=3-2*LESD
20477         PLCSUM=0D0
20478         DO 250 I=N+2,NCOP
20479           PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20480   250   CONTINUE
20481         DO 260 I=N+2,NCOP
20482           V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20483   260   CONTINUE
20484  
20485 C...Transfer extra three-momentum of current.
20486         DO 280 I=N+2,NCOP
20487           DO 270 J=1,3
20488             P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20489   270     CONTINUE
20490           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20491   280   CONTINUE
20492  
20493 C...Iterate change of initiator momentum to get energy right.
20494         ITER=0
20495   290   ITER=ITER+1
20496         PEEX=-P(N+1,4)-QNEW(4)
20497         PEMV=-P(N+1,3)/P(N+1,4)
20498         DO 300 I=N+2,NCOP
20499           PEEX=PEEX+P(I,4)
20500           PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20501   300   CONTINUE
20502         IF(ABS(PEMV).LT.1D-10) THEN
20503           MINT(51)=1
20504           MINT(57)=MINT(57)+1
20505           RETURN
20506         ENDIF
20507         PZCH=-PEEX/PEMV
20508         P(N+1,3)=P(N+1,3)+PZCH
20509         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)
20510         DO 310 I=N+2,NCOP
20511           P(I,3)=P(I,3)+V(I,1)*PZCH
20512           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20513   310   CONTINUE
20514         IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20515  
20516 C...Modify momenta in event record.
20517         HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20518      &  ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20519         IF(ABS(HBE).GE.1D0) THEN
20520           MINT(51)=1
20521           MINT(57)=MINT(57)+1
20522           RETURN
20523         ENDIF
20524         I=MINT(83)+5-LESD
20525         CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20526         DO 330 I=N+1,NCOP
20527           ICOP=K(I,3)
20528           DO 320 J=1,4
20529             P(ICOP,J)=P(I,J)
20530   320     CONTINUE
20531   330   CONTINUE
20532       ENDIF
20533  
20534 C...Check minimum invariant mass of remnant system(s).
20535       PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20536       PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20537       PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20538       PMIN(0)=SQRT(PMS(0))
20539       DO 340 JT=1,2
20540         PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20541         PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20542         PMIN(JT)=0D0
20543         IF(MINT(44+JT).EQ.1) GOTO 340
20544         MINT(105)=MINT(102+JT)
20545         MINT(109)=MINT(106+JT)
20546         CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20547         IF(MINT(51).NE.0) THEN
20548           MINT(57)=MINT(57)+1
20549           RETURN
20550         ENDIF
20551         IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20552         IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20553         IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20554         PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20555      &  P(MINT(83)+JT+2,2)**2)
20556   340 CONTINUE
20557       IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20558      &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20559      &PSYS(2,4))) THEN
20560         MINT(51)=1
20561         MINT(57)=MINT(57)+1
20562         RETURN
20563       ENDIF
20564  
20565 C...Loop over two remnants; skip if none there.
20566       I=NS
20567       DO 410 JT=1,2
20568         ISN(JT)=0
20569         IF(MINT(44+JT).EQ.1) GOTO 410
20570         IF(JT.EQ.1) IPU=IPU1
20571         IF(JT.EQ.2) IPU=IPU2
20572  
20573 C...Store first remnant parton.
20574         I=I+1
20575         IS(JT)=I
20576         ISN(JT)=1
20577         DO 350 J=1,5
20578           K(I,J)=0
20579           P(I,J)=0D0
20580           V(I,J)=0D0
20581   350   CONTINUE
20582         K(I,1)=1
20583         K(I,2)=KFLSP(JT)
20584         K(I,3)=MINT(83)+JT
20585         P(I,5)=PYMASS(K(I,2))
20586  
20587 C...First parton colour connections and kinematics.
20588         KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20589         IF(KCOL.EQ.2) THEN
20590           K(I,1)=3
20591           K(I,4)=MSTU(5)*IPU+IPU
20592           K(I,5)=MSTU(5)*IPU+IPU
20593           K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20594           K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20595         ELSEIF(KCOL.NE.0) THEN
20596           K(I,1)=3
20597           KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20598           K(I,KFLS+3)=IPU
20599           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20600         ENDIF
20601         IF(KFLCH(JT).EQ.0) THEN
20602           P(I,1)=-P(MINT(83)+JT+2,1)
20603           P(I,2)=-P(MINT(83)+JT+2,2)
20604           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20605           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20606           P(I,3)=PSYS(JT,3)
20607           P(I,4)=PSYS(JT,4)
20608  
20609 C...When extra remnant parton or hadron: store extra remnant.
20610         ELSE
20611           I=I+1
20612           ISN(JT)=2
20613           DO 360 J=1,5
20614             K(I,J)=0
20615             P(I,J)=0D0
20616             V(I,J)=0D0
20617   360     CONTINUE
20618           K(I,1)=1
20619           K(I,2)=KFLCH(JT)
20620           K(I,3)=MINT(83)+JT
20621           P(I,5)=PYMASS(K(I,2))
20622  
20623 C...Find parton colour connections of extra remnant.
20624           KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20625           IF(KCOL.EQ.2) THEN
20626             K(I,1)=3
20627             K(I,4)=MSTU(5)*IPU+IPU
20628             K(I,5)=MSTU(5)*IPU+IPU
20629             K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20630             K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20631           ELSEIF(KCOL.NE.0) THEN
20632             K(I,1)=3
20633             KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20634             K(I,KFLS+3)=IPU
20635             K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20636           ENDIF
20637  
20638 C...Relative transverse momentum when two remnants.
20639           LOOP=0
20640   370     LOOP=LOOP+1
20641           CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20642           IF(IABS(MINT(10+JT)).LT.20) THEN
20643             P(I-1,1)=0D0
20644             P(I-1,2)=0D0
20645           ELSE
20646             P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20647             P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20648           ENDIF
20649           PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20650           P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20651           P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20652           PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20653  
20654 C...Meson or baryon; photon as meson. For splitup below.
20655           IMB=1
20656           IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20657  
20658 C***Relative distribution for electron into two electrons. Temporary!
20659           IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20660      &    THEN
20661             CHI(JT)=PYR(0)
20662  
20663 C...Relative distribution of electron energy into electron plus parton.
20664           ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20665             XHRD=VINT(140+JT)
20666             XE=VINT(154+JT)
20667             CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20668  
20669 C...Relative distribution of energy for particle into two jets.
20670           ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20671             CHIK=PARP(92+2*IMB)
20672             IF(MSTP(92).LE.1) THEN
20673               IF(IMB.EQ.1) CHI(JT)=PYR(0)
20674               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20675             ELSEIF(MSTP(92).EQ.2) THEN
20676               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20677             ELSEIF(MSTP(92).EQ.3) THEN
20678               CUT=2D0*0.3D0/VINT(1)
20679   380         CHI(JT)=PYR(0)**2
20680               IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20681      &        (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20682             ELSEIF(MSTP(92).EQ.4) THEN
20683               CUT=2D0*0.3D0/VINT(1)
20684               CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20685   390         CHIR=CUT*CUTR**PYR(0)
20686               CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20687               IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20688             ELSE
20689               CUT=2D0*0.3D0/VINT(1)
20690               CUTA=CUT**(1D0-PARP(98))
20691               CUTB=(1D0+CUT)**(1D0-PARP(98))
20692   400         CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20693               IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20694      &        (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20695             ENDIF
20696  
20697 C...Relative distribution of energy for particle into jet plus particle.
20698           ELSE
20699             IF(MSTP(94).LE.1) THEN
20700               IF(IMB.EQ.1) CHI(JT)=PYR(0)
20701               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20702               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20703             ELSEIF(MSTP(94).EQ.2) THEN
20704               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20705               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20706             ELSEIF(MSTP(94).EQ.3) THEN
20707               CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20708               CHI(JT)=ZZ
20709             ELSE
20710               CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20711               CHI(JT)=ZZ
20712             ENDIF
20713           ENDIF
20714  
20715 C...Construct total transverse mass; reject if too large.
20716           CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20717           PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20718           IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20719             IF(LOOP.LT.100) THEN
20720               GOTO 370
20721             ELSE
20722               MINT(51)=1
20723               MINT(57)=MINT(57)+1
20724               RETURN
20725             ENDIF
20726           ENDIF
20727           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20728           VINT(158+JT)=CHI(JT)
20729  
20730 C...Subdivide longitudinal momentum according to value selected above.
20731           PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20732           P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20733           P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20734           P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20735           P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20736         ENDIF
20737   410 CONTINUE
20738       N=I
20739  
20740 C...Check if longitudinal boosts needed - if so pick two systems.
20741       PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20742      &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20743       IF(PDEV.LE.1D-6*VINT(1)) RETURN
20744       IF(ISN(1).EQ.0) THEN
20745         IR=0
20746         IL=2
20747       ELSEIF(ISN(2).EQ.0) THEN
20748         IR=1
20749         IL=0
20750       ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20751         IR=1
20752         IL=2
20753       ELSEIF(VINT(143).GT.0.2D0) THEN
20754         IR=1
20755         IL=0
20756       ELSEIF(VINT(144).GT.0.2D0) THEN
20757         IR=0
20758         IL=2
20759       ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20760         IR=1
20761         IL=0
20762       ELSE
20763         IR=0
20764         IL=2
20765       ENDIF
20766       IG=3-IR-IL
20767  
20768 C...E+-pL wanted for system to be modified.
20769       IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20770         PPB=VINT(1)
20771         PNB=VINT(1)
20772       ELSE
20773         PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20774         PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20775       ENDIF
20776  
20777 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20778       IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20779         PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20780         PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20781         DO 420 J=1,4
20782           PSYS(0,J)=0D0
20783   420   CONTINUE
20784         DO 450 I=MINT(84)+1,NS
20785           IF(K(I,1).GT.10) GOTO 450
20786           INCL=0
20787           IORIG=I
20788   430     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20789           IORIG=K(IORIG,3)
20790           IF(IORIG.GT.LPIN) GOTO 430
20791           IF(INCL.EQ.0) GOTO 450
20792           DO 440 J=1,4
20793             PSYS(0,J)=PSYS(0,J)+P(I,J)
20794   440     CONTINUE
20795   450   CONTINUE
20796         PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20797         PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20798         PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20799       ENDIF
20800  
20801 C...Construct longitudinal boosts.
20802       DPMTB=PPB*PNB
20803       DPMTR=PMS(IR)
20804       DPMTL=PMS(IL)
20805       DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20806       IF(DSQLAM.LE.1D-6*DPMTB) THEN
20807         MINT(51)=1
20808         MINT(57)=MINT(57)+1
20809         RETURN
20810       ENDIF
20811       DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20812       DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20813      &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20814       DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20815      &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20816       DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20817       DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20818  
20819 C...Perform longitudinal boosts.
20820       IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20821         P(IS(1),3)=0D0
20822         P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20823       ELSEIF(IR.EQ.1) THEN
20824         CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20825       ELSEIF(IDISXQ.EQ.1) THEN
20826         DO 470 I=I1,NS
20827           INCL=0
20828           IORIG=I
20829   460     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20830           IORIG=K(IORIG,3)
20831           IF(IORIG.GT.LPIN) GOTO 460
20832           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20833   470   CONTINUE
20834       ELSE
20835         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20836       ENDIF
20837       IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20838         P(IS(2),3)=0D0
20839         P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20840       ELSEIF(IL.EQ.2) THEN
20841         CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20842       ELSEIF(IDISXQ.EQ.1) THEN
20843         DO 490 I=I1,NS
20844           INCL=0
20845           IORIG=I
20846   480     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20847           IORIG=K(IORIG,3)
20848           IF(IORIG.GT.LPIN) GOTO 480
20849           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20850   490   CONTINUE
20851       ELSE
20852         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20853       ENDIF
20854  
20855 C...Final check that energy-momentum conservation worked.
20856       PESUM=0D0
20857       PZSUM=0D0
20858       DO 500 I=MINT(84)+1,N
20859         IF(K(I,1).GT.10) GOTO 500
20860         PESUM=PESUM+P(I,4)
20861         PZSUM=PZSUM+P(I,3)
20862   500 CONTINUE
20863       PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20864       IF(PDEV.GT.1D-4*VINT(1)) THEN
20865         MINT(51)=1
20866         MINT(57)=MINT(57)+1
20867         RETURN
20868       ENDIF
20869  
20870 C...Calculate rotation and boost from overall CM frame to
20871 C...hadronic CM frame in leptoproduction.
20872       MINT(91)=0
20873       IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20874         MINT(91)=1
20875         LESD=1
20876         IF(MINT(42).EQ.1) LESD=2
20877         LPIN=MINT(83)+3-LESD
20878  
20879 C...Sum upp momenta of everything not lepton or photon to define boost.
20880         DO 510 J=1,4
20881           PSUM(J)=0D0
20882   510   CONTINUE
20883         DO 530 I=1,N
20884           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20885           IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20886           IF(K(I,2).EQ.22) GOTO 530
20887           DO 520 J=1,4
20888             PSUM(J)=PSUM(J)+P(I,J)
20889   520     CONTINUE
20890   530   CONTINUE
20891         VINT(223)=-PSUM(1)/PSUM(4)
20892         VINT(224)=-PSUM(2)/PSUM(4)
20893         VINT(225)=-PSUM(3)/PSUM(4)
20894  
20895 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20896         K(N+1,1)=1
20897         DO 540 J=1,5
20898           P(N+1,J)=P(LPIN,J)
20899           V(N+1,J)=V(LPIN,J)
20900   540   CONTINUE
20901         CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20902         VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20903         CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20904         IF(LESD.EQ.2) THEN
20905           VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20906         ELSE
20907           VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20908         ENDIF
20909       ENDIF
20910  
20911       RETURN
20912       END
20913  
20914 C*********************************************************************
20915  
20916 C...PYMIGN
20917 C...Initializes treatment of new multiple interactions scenario,
20918 C...selects kinematics of hardest interaction if low-pT physics
20919 C...included in run, and generates all non-hardest interactions.
20920  
20921       SUBROUTINE PYMIGN(MMUL)
20922  
20923 C...Double precision and integer declarations.
20924       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20925       IMPLICIT INTEGER(I-N)
20926       INTEGER PYK,PYCHGE,PYCOMP
20927       EXTERNAL PYALPS
20928       DOUBLE PRECISION PYALPS
20929 C...Commonblocks.
20930       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20931       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20932       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20933       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20934       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20935       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20936       COMMON/PYINT1/MINT(400),VINT(400)
20937       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20938       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20939       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20940       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20941       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20942      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20943      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
20944       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20945      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20946 C...Local arrays and saved variables.
20947       DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20948      &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20949       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20950      &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20951      &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20952  
20953 C...Initialization of multiple interaction treatment.
20954       IF(MMUL.EQ.1) THEN
20955         IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20956         ISUB=96
20957         MINT(1)=96
20958         VINT(63)=0D0
20959         VINT(64)=0D0
20960         VINT(143)=1D0
20961         VINT(144)=1D0
20962  
20963 C...Loop over phase space points: xT2 choice in 20 bins.
20964   100   SIGSUM=0D0
20965         DO 120 IXT2=1,20
20966           NMUL(IXT2)=MSTP(83)
20967           SIGM(IXT2)=0D0
20968           DO 110 ITRY=1,MSTP(83)
20969             RSCA=0.05D0*((21-IXT2)-PYR(0))
20970             XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20971             XT2=MAX(0.01D0*VINT(149),XT2)
20972             VINT(25)=XT2
20973  
20974 C...Choose tau and y*. Calculate cos(theta-hat).
20975             IF(PYR(0).LE.COEF(ISUB,1)) THEN
20976               TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20977               TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20978             ELSE
20979               TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20980             ENDIF
20981             VINT(21)=TAU
20982             CALL PYKLIM(2)
20983             RYST=PYR(0)
20984             MYST=1
20985             IF(RYST.GT.COEF(ISUB,8)) MYST=2
20986             IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20987             CALL PYKMAP(2,MYST,PYR(0))
20988             VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20989  
20990 C...Calculate differential cross-section.
20991             VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20992             CALL PYSIGH(NCHN,SIGS)
20993             SIGM(IXT2)=SIGM(IXT2)+SIGS
20994   110     CONTINUE
20995           SIGSUM=SIGSUM+SIGM(IXT2)
20996   120   CONTINUE
20997         SIGSUM=SIGSUM/(20D0*MSTP(83))
20998  
20999 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
21000         IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
21001           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
21002      &    PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
21003           PARP(82)=0.9D0*PARP(82)
21004           VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
21005      &    VINT(2)
21006           GOTO 100
21007         ENDIF
21008         IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
21009      &  PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
21010  
21011 C...Start iteration to find k factor.
21012         YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
21013         P83A=(1D0-PARP(83))**2
21014         P83B=2D0*PARP(83)*(1D0-PARP(83))
21015         P83C=PARP(83)**2
21016         CQ2I=1D0/PARP(84)**2
21017         CQ2R=2D0/(1D0+PARP(84)**2)
21018         SO=0.5D0
21019         XI=0D0
21020         YI=0D0
21021         XF=0D0
21022         YF=0D0
21023         XK=0.5D0
21024         IIT=0
21025   130   IF(IIT.EQ.0) THEN
21026           XK=2D0*XK
21027         ELSEIF(IIT.EQ.1) THEN
21028           XK=0.5D0*XK
21029         ELSE
21030           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
21031         ENDIF
21032  
21033 C...Evaluate overlap integrals. Find where to divide the b range.
21034         IF(MSTP(82).EQ.2) THEN
21035           SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
21036           SOP=SP/PARU(1)
21037         ELSE
21038           IF(MSTP(82).EQ.3) THEN
21039             DELTAB=0.02D0
21040           ELSEIF(MSTP(82).EQ.4) THEN
21041             DELTAB=MIN(0.01D0,0.05D0*PARP(84))
21042           ELSE
21043             POWIP=MAX(0.4D0,PARP(83))
21044             RPWIP=2D0/POWIP-1D0
21045             DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
21046             SO=0D0
21047           ENDIF
21048           SP=0D0
21049           SOP=0D0
21050           BSP=0D0
21051           SOHIGH=0D0
21052           IBDIV=0
21053           B=-0.5D0*DELTAB
21054   140     B=B+DELTAB
21055           IF(MSTP(82).EQ.3) THEN
21056             OV=EXP(-B**2)/PARU(2)
21057           ELSEIF(MSTP(82).EQ.4) THEN
21058             OV=(P83A*EXP(-MIN(50D0,B**2))+
21059      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21060      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21061           ELSE
21062             OV=EXP(-B**POWIP)/PARU(2)
21063             SO=SO+PARU(2)*B*DELTAB*OV
21064           ENDIF
21065           IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
21066           PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
21067           SP=SP+PARU(2)*B*DELTAB*PACC
21068           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
21069           BSP=BSP+B*PARU(2)*B*DELTAB*PACC
21070           IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
21071             IBDIV=1 
21072             BDIV=B+0.5D0*DELTAB
21073           ENDIF
21074           IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
21075         ENDIF
21076         YK=PARU(1)*XK*SO/SP
21077  
21078 C...Continue iteration until convergence.
21079         IF(YK.LT.YKE) THEN
21080           XI=XK
21081           YI=YK
21082           IF(IIT.EQ.1) IIT=2
21083         ELSE
21084           XF=XK
21085           YF=YK
21086           IF(IIT.EQ.0) IIT=1
21087         ENDIF
21088         IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
21089  
21090 C...Store some results for subsequent use.
21091         BAVG=BSP/SP
21092         VINT(145)=SIGSUM
21093         VINT(146)=SOP/SO
21094         VINT(147)=SOP/SP
21095         VNT145=VINT(145)
21096         VNT146=VINT(146)
21097         VNT147=VINT(147)
21098 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
21099         PIK=(VNT146/VNT147)*YKE
21100 
21101 C...Find relative weight for low and high impact parameter..
21102       PLOWB=PARU(1)*BDIV**2
21103       IF(MSTP(82).EQ.3) THEN
21104         PHIGHB=PIK*0.5*EXP(-BDIV**2)
21105       ELSEIF(MSTP(82).EQ.4) THEN
21106         S4A=P83A*EXP(-BDIV**2)
21107         S4B=P83B*EXP(-BDIV**2*CQ2R)
21108         S4C=P83C*EXP(-BDIV**2*CQ2I)
21109         PHIGHB=PIK*0.5*(S4A+S4B+S4C)
21110       ELSEIF(PARP(83).GE.1.999D0) THEN
21111         PHIGHB=PIK*SOHIGH
21112         B2RPDV=BDIV**POWIP
21113       ELSE
21114         PHIGHB=PIK*SOHIGH
21115         B2RPDV=BDIV**POWIP
21116         B2RPMX=MAX(2D0*RPWIP,B2RPDV)
21117       ENDIF 
21118       PALLB=PLOWB+PHIGHB
21119  
21120 C...Initialize iteration in xT2 for hardest interaction.
21121       ELSEIF(MMUL.EQ.2) THEN
21122         VINT(145)=VNT145
21123         VINT(146)=VNT146
21124         VINT(147)=VNT147
21125         IF(MSTP(82).LE.0) THEN
21126         ELSEIF(MSTP(82).EQ.1) THEN
21127           XT2=1D0
21128           SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21129           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21130      &    VINT(317)/(VINT(318)*VINT(320))
21131           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21132         ELSEIF(MSTP(82).EQ.2) THEN
21133           XT2=1D0
21134           XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21135      &    VINT(149)*(1D0+VINT(149))
21136         ELSE
21137           XC2=4D0*CKIN(3)**2/VINT(2)
21138           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
21139         ENDIF
21140 
21141 C...Select impact parameter for hardest interaction.
21142         IF(MSTP(82).LE.2) RETURN
21143   142   IF(PYR(0)*PALLB.LT.PLOWB) THEN
21144 C...Treatment in low b region.
21145           MINT(39)=1
21146           B=BDIV*SQRT(PYR(0)) 
21147           IF(MSTP(82).EQ.3) THEN
21148             OV=EXP(-B**2)/PARU(2)
21149           ELSEIF(MSTP(82).EQ.4) THEN
21150             OV=(P83A*EXP(-MIN(50D0,B**2))+
21151      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21152      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21153           ELSE
21154             OV=EXP(-B**POWIP)/PARU(2)
21155           ENDIF  
21156           VINT(148)=OV/VNT147
21157           PACC=1D0-EXP(-MIN(50D0,PIK*OV))
21158           XT2=1D0
21159           XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21160      &    VINT(149)*(1D0+VINT(149))
21161         ELSE
21162 C...Treatment in high b region.
21163           MINT(39)=2
21164           IF(MSTP(82).EQ.3) THEN
21165             B=SQRT(BDIV**2-LOG(PYR(0)))
21166             OV=EXP(-B**2)/PARU(2)
21167           ELSEIF(MSTP(82).EQ.4) THEN
21168             S4RNDM=PYR(0)*(S4A+S4B+S4C)
21169             IF(S4RNDM.LT.S4A) THEN
21170               B=SQRT(BDIV**2-LOG(PYR(0)))
21171             ELSEIF(S4RNDM.LT.S4A+S4B) THEN
21172               B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
21173             ELSE
21174               B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
21175             ENDIF    
21176             OV=(P83A*EXP(-MIN(50D0,B**2))+
21177      &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21178      &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21179           ELSEIF(PARP(83).GE.1.999D0) THEN
21180   144       B2RPW=B2RPDV-LOG(PYR(0))
21181             ACCIP=(B2RPW/B2RPDV)**RPWIP
21182             IF(ACCIP.LT.PYR(0)) GOTO 144
21183             OV=EXP(-B2RPW)/PARU(2)
21184             B=B2RPW**(1D0/POWIP)
21185           ELSE
21186   146       B2RPW=B2RPDV-2D0*LOG(PYR(0))
21187             ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
21188             IF(ACCIP.LT.PYR(0)) GOTO 146
21189             OV=EXP(-B2RPW)/PARU(2)
21190             B=B2RPW**(1D0/POWIP)
21191           ENDIF  
21192           VINT(148)=OV/VNT147
21193           PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
21194         ENDIF
21195         IF(PACC.LT.PYR(0)) GOTO 142
21196         VINT(139)=B/BAVG
21197  
21198       ELSEIF(MMUL.EQ.3) THEN
21199 C...Low-pT or multiple interactions (first semihard interaction):
21200 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
21201 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
21202         ISUB=MINT(1)
21203         VINT(145)=VNT145
21204         VINT(146)=VNT146
21205         VINT(147)=VNT147
21206         IF(MSTP(82).LE.0) THEN
21207           XT2=0D0
21208         ELSEIF(MSTP(82).EQ.1) THEN
21209           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21210 C...Use with "Sudakov" for low b values when impact parameter dependence.
21211         ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
21212           IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
21213      &    VINT(149)))).GT.PYR(0)) XT2=1D0
21214           IF(XT2.GE.1D0) THEN
21215             XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
21216      &      PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
21217      &      VINT(149)
21218           ELSE
21219             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
21220      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
21221      &      VINT(149)
21222           ENDIF
21223           XT2=MAX(0.01D0*VINT(149),XT2)
21224 C...Use without "Sudakov" for high b values when impact parameter dep.
21225         ELSE
21226           XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
21227      &    PYR(0)*(1D0-XC2))-VINT(149)
21228           XT2=MAX(0.01D0*VINT(149),XT2)
21229         ENDIF
21230         VINT(25)=XT2
21231  
21232 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
21233         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
21234           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
21235           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
21236           ISUB=95
21237           MINT(1)=ISUB
21238           VINT(21)=1D-12*VINT(149)
21239           VINT(22)=0D0
21240           VINT(23)=0D0
21241           VINT(25)=1D-12*VINT(149)
21242  
21243         ELSE
21244 C...Multiple interactions (first semihard interaction).
21245 C...Choose tau and y*. Calculate cos(theta-hat).
21246           IF(PYR(0).LE.COEF(ISUB,1)) THEN
21247             TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21248             TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21249           ELSE
21250             TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21251           ENDIF
21252           VINT(21)=TAU
21253           CALL PYKLIM(2)
21254           RYST=PYR(0)
21255           MYST=1
21256           IF(RYST.GT.COEF(ISUB,8)) MYST=2
21257           IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21258           CALL PYKMAP(2,MYST,PYR(0))
21259           VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21260         ENDIF
21261         VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
21262  
21263 C...Store results of cross-section calculation.
21264       ELSEIF(MMUL.EQ.4) THEN
21265         ISUB=MINT(1)
21266         VINT(145)=VNT145
21267         VINT(146)=VNT146
21268         VINT(147)=VNT147
21269         XTS=VINT(25)
21270         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
21271         IF(ISET(ISUB).EQ.2)
21272      &  XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21273         IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
21274         RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
21275      &  (XTS+VINT(149))))
21276         IRBIN=INT(1D0+20D0*RBIN)
21277         IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
21278           NMUL(IRBIN)=NMUL(IRBIN)+1
21279           SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
21280         ENDIF
21281  
21282 C...Choose impact parameter if not already done.
21283       ELSEIF(MMUL.EQ.5) THEN
21284         ISUB=MINT(1)
21285         VINT(145)=VNT145
21286         VINT(146)=VNT146
21287         VINT(147)=VNT147
21288   150   IF(MINT(39).GT.0) THEN
21289         ELSEIF(MSTP(82).EQ.3) THEN
21290           EXPB2=PYR(0)
21291           B2=-LOG(PYR(0))
21292           VINT(148)=EXPB2/(PARU(2)*VNT147)
21293           VINT(139)=SQRT(B2)/BAVG
21294         ELSEIF(MSTP(82).EQ.4) THEN
21295           RTYPE=PYR(0)
21296           IF(RTYPE.LT.P83A) THEN
21297             B2=-LOG(PYR(0))
21298           ELSEIF(RTYPE.LT.P83A+P83B) THEN
21299             B2=-LOG(PYR(0))/CQ2R
21300           ELSE
21301             B2=-LOG(PYR(0))/CQ2I
21302           ENDIF
21303           VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
21304      &    P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
21305      &    P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
21306           VINT(139)=SQRT(B2)/BAVG
21307         ELSEIF(PARP(83).GE.1.999D0) THEN
21308           POWIP=MAX(2D0,PARP(83))
21309           RPWIP=2D0/POWIP-1D0
21310           PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
21311   160     IF(PYR(0).LT.PROB1) THEN
21312             B2RPW=PYR(0)**(0.5D0*POWIP)
21313             ACCIP=EXP(-B2RPW)
21314           ELSE
21315             B2RPW=1D0-LOG(PYR(0))
21316             ACCIP=B2RPW**RPWIP
21317           ENDIF
21318           IF(ACCIP.LT.PYR(0)) GOTO 160
21319           VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21320           VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21321         ELSE
21322           POWIP=MAX(0.4D0,PARP(83))
21323           RPWIP=2D0/POWIP-1D0
21324           PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
21325   170     IF(PYR(0).LT.PROB1) THEN
21326             B2RPW=2D0*RPWIP*PYR(0)
21327             ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
21328           ELSE
21329             B2RPW=2D0*(RPWIP-LOG(PYR(0)))
21330             ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
21331           ENDIF
21332           IF(ACCIP.LT .PYR(0)) GOTO 170
21333           VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21334           VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21335         ENDIF
21336  
21337 C...Multiple interactions (variable impact parameter) : reject with
21338 C...probability exp(-overlap*cross-section above pT/normalization).
21339 C...Does not apply to low-b region, where "Sudakov" already included.
21340         VINT(150)=1D0 
21341         IF(MINT(39).NE.1) THEN
21342           RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
21343           SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
21344           DO 180 IBIN=IRBIN+1,20
21345             RNCOR=RNCOR+NMUL(IBIN)
21346             SIGCOR=SIGCOR+SIGM(IBIN)
21347   180     CONTINUE
21348           SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
21349           IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
21350           VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
21351      &    SIGABV/MAX(1D-10,SIGT(0,0,5))))
21352         ENDIF
21353         IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
21354      &  ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
21355      &  .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
21356           IF(VINT(150).LT.PYR(0)) GOTO 150
21357           VINT(150)=1D0
21358         ENDIF
21359  
21360 C...Generate additional multiple semihard interactions.
21361       ELSEIF(MMUL.EQ.6) THEN
21362  
21363 C...Save data for hardest initeraction, to be restored.
21364         ISUBSV=MINT(1)
21365         VINT(145)=VNT145
21366         VINT(146)=VNT146
21367         VINT(147)=VNT147
21368         M13SV=MINT(13)
21369         M14SV=MINT(14)
21370         M15SV=MINT(15)
21371         M16SV=MINT(16)
21372         M21SV=MINT(21)
21373         M22SV=MINT(22)
21374         DO 190 J=11,80
21375           VINTSV(J)=VINT(J)
21376   190   CONTINUE
21377         V141SV=VINT(141)
21378         V142SV=VINT(142)
21379  
21380 C...Store data on hardest interaction.
21381         XMI(1,1)=VINT(141)
21382         XMI(2,1)=VINT(142)
21383         PT2MI(1)=VINT(54)
21384         IMISEP(0)=MINT(84)
21385         IMISEP(1)=N
21386  
21387 C...Change process to generate; sum of x values so far.
21388         ISUB=96
21389         MINT(1)=96
21390         VINT(143)=1D0-VINT(141)
21391         VINT(144)=1D0-VINT(142)
21392         VINT(151)=0D0
21393         VINT(152)=0D0
21394  
21395 C...Initialize factors for PDF reshaping.
21396         DO 230 JS=1,2
21397           KFBEAM=MINT(10+JS)
21398           KFABM=IABS(KFBEAM)
21399           KFSBM=ISIGN(1,KFBEAM)
21400  
21401 C...Zero flavour content of incoming beam particle.
21402           KFIVAL(JS,1)=0
21403           KFIVAL(JS,2)=0
21404           KFIVAL(JS,3)=0
21405 C...Flavour content of baryon.
21406           IF(KFABM.GT.1000) THEN
21407             KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
21408             KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
21409             KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
21410 C...Flavour content of pi+-, K+-.
21411           ELSEIF(KFABM.EQ.211) THEN
21412             KFIVAL(JS,1)=KFSBM*2
21413             KFIVAL(JS,2)=-KFSBM
21414           ELSEIF(KFABM.EQ.321) THEN
21415             KFIVAL(JS,1)=-KFSBM*3
21416             KFIVAL(JS,2)=KFSBM*2
21417 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
21418           ENDIF
21419  
21420 C...Zero initial valence and companion content.
21421           DO 200 IFL=-6,6
21422             NVC(JS,IFL)=0
21423   200     CONTINUE
21424  
21425 C...Initiate listing of all incoming partons from two sides.
21426           NMI(JS)=0
21427           DO 210 I=MINT(84)+1,N
21428             IF(K(I,3).EQ.MINT(83)+2+JS) THEN
21429               IMI(JS,1,1)=I
21430               IMI(JS,1,2)=0
21431             ENDIF
21432   210     CONTINUE
21433  
21434 C...Decide whether quarks in hard scattering were valence or sea.
21435           IFL=K(IMI(JS,1,1),2)
21436           IF (IABS(IFL).GT.6) GOTO 230
21437  
21438 C...Get PDFs at X and Q2 of the parton shower initiator for the
21439 C...hard scattering.
21440           X=VINT(140+JS)
21441           IF(MSTP(61).GE.1) THEN
21442             Q2=PARP(62)**2
21443           ELSE
21444             Q2=VINT(54)
21445           ENDIF
21446 C...Note: XPSVC = x*pdf.
21447           MINT(30)=JS
21448           CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21449           SEA=XPSVC(IFL,-1)
21450           VAL=XPSVC(IFL,0)
21451  
21452 C...Decide (Extra factor x cancels in the division).
21453           RVCS=PYR(0)*(SEA+VAL)
21454           IVNOW=1
21455   220     IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21456 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21457             IVNOW=0
21458             IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21459             IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21460             IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21461             IF(KFIVAL(JS,1).EQ.0) THEN
21462               IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21463               IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21464               IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21465      &        (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21466             ENDIF
21467             IF(IVNOW.EQ.0) GOTO 220
21468 C...Mark valence.
21469             IMI(JS,1,2)=0
21470 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21471             IF(KFIVAL(JS,1).EQ.0) THEN
21472               IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21473                 KFIVAL(JS,1)=IFL
21474                 KFIVAL(JS,2)=-IFL
21475               ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21476                 KFIVAL(JS,1)=IFL
21477                 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21478                 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21479               ENDIF
21480             ENDIF
21481  
21482 C...If sea, add opposite sign companion parton. Store X and I.
21483           ELSE
21484             NVC(JS,-IFL)=NVC(JS,-IFL)+1
21485             XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21486 C...Set pointer to companion
21487             IMI(JS,1,2)=-NVC(JS,-IFL)
21488           ENDIF
21489   230   CONTINUE
21490  
21491 C...Update counter number of multiple interactions.
21492         NMI(1)=1
21493         NMI(2)=1
21494  
21495 C...Set up starting values for iteration in xT2.
21496         IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21497      &  ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21498      &  ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21499      &  ISUBSV.NE.96)) THEN
21500           XT2=(1D0-VINT(141))*(1D0-VINT(142))
21501         ELSE
21502           XT2=VINT(25)
21503           IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21504           IF(ISET(ISUBSV).EQ.2)
21505      &    XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21506           IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21507         ENDIF
21508         IF(MSTP(82).LE.1) THEN
21509           SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21510           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21511      &    VINT(317)/(VINT(318)*VINT(320))
21512           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21513         ELSE
21514           XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21515      &    MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21516         ENDIF
21517         VINT(63)=0D0
21518         VINT(64)=0D0
21519  
21520 C...Iterate downwards in xT2.
21521   240   IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21522           XT2=0D0
21523           GOTO 440
21524         ELSEIF(MSTP(82).LE.1) THEN
21525           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21526           IF(XT2.LT.VINT(149)) GOTO 440
21527         ELSE
21528           IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21529           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21530      &    LOG(PYR(0)))-VINT(149)
21531           IF(XT2.LE.0D0) GOTO 440
21532           XT2=MAX(0.01D0*VINT(149),XT2)
21533         ENDIF
21534         VINT(25)=XT2
21535  
21536 C...Choose tau and y*. Calculate cos(theta-hat).
21537         IF(PYR(0).LE.COEF(ISUB,1)) THEN
21538           TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21539           TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21540         ELSE
21541           TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21542         ENDIF
21543         VINT(21)=TAU
21544 C...New: require shat > 1.
21545         IF(TAU*VINT(2).LT.1D0) GOTO 240
21546         CALL PYKLIM(2)
21547         RYST=PYR(0)
21548         MYST=1
21549         IF(RYST.GT.COEF(ISUB,8)) MYST=2
21550         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21551         CALL PYKMAP(2,MYST,PYR(0))
21552         VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21553  
21554 C...Check that x not used up. Accept or reject kinematical variables.
21555         X1M=SQRT(TAU)*EXP(VINT(22))
21556         X2M=SQRT(TAU)*EXP(-VINT(22))
21557         IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21558         VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21559         CALL PYSIGH(NCHN,SIGS)
21560         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21561         IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21562         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21563  
21564 C...Reset K, P and V vectors.
21565         DO 260 I=N+1,N+4
21566           DO 250 J=1,5
21567             K(I,J)=0
21568             P(I,J)=0D0
21569             V(I,J)=0D0
21570   250     CONTINUE
21571   260   CONTINUE
21572         PT=0.5D0*VINT(1)*SQRT(XT2)
21573  
21574 C...Choose flavour of reacting partons (and subprocess).
21575         RSIGS=SIGS*PYR(0)
21576         DO 270 ICHN=1,NCHN
21577           KFL1=ISIG(ICHN,1)
21578           KFL2=ISIG(ICHN,2)
21579           ICONMI=ISIG(ICHN,3)
21580           RSIGS=RSIGS-SIGH(ICHN)
21581           IF(RSIGS.LE.0D0) GOTO 280
21582   270   CONTINUE
21583  
21584 C...Reassign to appropriate process codes.
21585   280   ISUBMI=ICONMI/10
21586         ICONMI=MOD(ICONMI,10)
21587  
21588 C...Choose new quark flavour for annihilation graphs
21589         IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21590           SH=TAU*VINT(2)
21591           CALL PYWIDT(21,SH,WDTP,WDTE)
21592   290     RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21593           DO 300 I=1,MDCY(21,3)
21594             KFLF=KFDP(I+MDCY(21,2)-1,1)
21595             RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21596             IF(RKFL.LE.0D0) GOTO 310
21597   300     CONTINUE
21598   310     IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21599             IF(KFLF.GE.4) GOTO 290
21600           ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21601             KFLF=4
21602             ICONMI=ICONMI-2
21603           ELSEIF(ISUBMI.EQ.53) THEN
21604             KFLF=5
21605             ICONMI=ICONMI-4
21606           ENDIF
21607         ENDIF
21608  
21609 C...Final state flavours and colour flow: default values
21610         JS=1
21611         KFL3=KFL1
21612         KFL4=KFL2
21613         KCC=20
21614         KCS=ISIGN(1,KFL1)
21615  
21616         IF(ISUBMI.EQ.11) THEN
21617 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21618           KCC=ICONMI
21619           IF(KFL1*KFL2.LT.0) KCC=KCC+2
21620  
21621         ELSEIF(ISUBMI.EQ.12) THEN
21622 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21623           KFL3=ISIGN(KFLF,KFL1)
21624           KFL4=-KFL3
21625           KCC=4
21626  
21627         ELSEIF(ISUBMI.EQ.13) THEN
21628 C...f + fbar -> g + g; th arbitrary
21629           KFL3=21
21630           KFL4=21
21631           KCC=ICONMI+4
21632  
21633         ELSEIF(ISUBMI.EQ.28) THEN
21634 C...f + g -> f + g; th = (p(f)-p(f))**2
21635           IF(KFL1.EQ.21) JS=2
21636           KCC=ICONMI+6
21637           IF(KFL1.EQ.21) KCC=KCC+2
21638           IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21639           IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21640  
21641         ELSEIF(ISUBMI.EQ.53) THEN
21642 C...g + g -> f + fbar; th arbitrary
21643           KCS=(-1)**INT(1.5D0+PYR(0))
21644           KFL3=ISIGN(KFLF,KCS)
21645           KFL4=-KFL3
21646           KCC=ICONMI+10
21647  
21648         ELSEIF(ISUBMI.EQ.68) THEN
21649 C...g + g -> g + g; th arbitrary
21650           KCC=ICONMI+12
21651           KCS=(-1)**INT(1.5D0+PYR(0))
21652         ENDIF
21653  
21654 C...Store flavours of scattering.
21655         MINT(13)=KFL1
21656         MINT(14)=KFL2
21657         MINT(15)=KFL1
21658         MINT(16)=KFL2
21659         MINT(21)=KFL3
21660         MINT(22)=KFL4
21661  
21662 C...Set flavours and mothers of scattering partons.
21663         K(N+1,1)=14
21664         K(N+2,1)=14
21665         K(N+3,1)=3
21666         K(N+4,1)=3
21667         K(N+1,2)=KFL1
21668         K(N+2,2)=KFL2
21669         K(N+3,2)=KFL3
21670         K(N+4,2)=KFL4
21671         K(N+1,3)=MINT(83)+1
21672         K(N+2,3)=MINT(83)+2
21673         K(N+3,3)=N+1
21674         K(N+4,3)=N+2
21675  
21676 C...Store colour connection indices.
21677         DO 320 J=1,2
21678           JC=J
21679           IF(KCS.EQ.-1) JC=3-J
21680           IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21681           IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21682           IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21683           IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21684   320   CONTINUE
21685  
21686 C...Store incoming and outgoing partons in their CM-frame.
21687         SHR=SQRT(TAU)*VINT(1)
21688         P(N+1,3)=0.5D0*SHR
21689         P(N+1,4)=0.5D0*SHR
21690         P(N+2,3)=-0.5D0*SHR
21691         P(N+2,4)=0.5D0*SHR
21692         P(N+3,5)=PYMASS(K(N+3,2))
21693         P(N+4,5)=PYMASS(K(N+4,2))
21694         IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21695         P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21696         P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21697         P(N+4,4)=SHR-P(N+3,4)
21698         P(N+4,3)=-P(N+3,3)
21699  
21700 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21701         PHI=PARU(2)*PYR(0)
21702         CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21703  
21704 C...Set up default values before showers.
21705         MINT(31)=MINT(31)+1
21706         IPU1=N+1
21707         IPU2=N+2
21708         IPU3=N+3
21709         IPU4=N+4
21710         VINT(141)=VINT(41)
21711         VINT(142)=VINT(42)
21712         N=N+4
21713  
21714 C...Showering of initial state partons (optional).
21715 C...Note: no showering of final state partons here; it comes later.
21716         IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21717           MINT(51)=0
21718           ALAMSV=PARJ(81)
21719           PARJ(81)=PARP(72)
21720           NSAV=N
21721           DO 340 I=1,4
21722             DO 330 J=1,5
21723               KSAV(I,J)=K(N-4+I,J)
21724               PSAV(I,J)=P(N-4+I,J)
21725   330       CONTINUE
21726   340     CONTINUE
21727           CALL PYSSPA(IPU1,IPU2)
21728           PARJ(81)=ALAMSV
21729 C...If shower failed then restore to situation before shower.
21730           IF(MINT(51).GE.1) THEN
21731             N=NSAV
21732             DO 360 I=1,4
21733               DO 350 J=1,5
21734                 K(N-4+I,J)=KSAV(I,J)
21735                 P(N-4+I,J)=PSAV(I,J)
21736   350         CONTINUE
21737   360       CONTINUE
21738             IPU1=N-3
21739             IPU2=N-2
21740             VINT(141)=VINT(41)
21741             VINT(142)=VINT(42)
21742           ENDIF
21743         ENDIF
21744  
21745 C...Keep track of loose colour ends and information on scattering.
21746   370   IMI(1,MINT(31),1)=IPU1
21747         IMI(2,MINT(31),1)=IPU2
21748         IMI(1,MINT(31),2)=0
21749         IMI(2,MINT(31),2)=0
21750         XMI(1,MINT(31))=VINT(141)
21751         XMI(2,MINT(31))=VINT(142)
21752         PT2MI(MINT(31))=VINT(54)
21753         IMISEP(MINT(31))=N
21754  
21755 C...Decide whether quarks in last scattering were valence, companion or
21756 C...sea.
21757         DO 430 JS=1,2
21758           KFBEAM=MINT(10+JS)
21759           KFSBM=ISIGN(1,MINT(10+JS))
21760           IFL=K(IMI(JS,MINT(31),1),2)
21761           IMI(JS,MINT(31),2)=0
21762           IF (IABS(IFL).GT.6) GOTO 430
21763  
21764 C...Get PDFs at X and Q2 of the parton shower initiator for the
21765 C...last scattering. At this point VINT(143:144) do not yet
21766 C...include the scattered x values VINT(141:142).
21767           X=VINT(140+JS)/VINT(142+JS)
21768           IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21769             Q2=PARP(62)**2
21770           ELSE
21771             Q2=VINT(54)
21772           ENDIF
21773 C...Note: XPSVC = x*pdf.
21774           MINT(30)=JS
21775           CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21776           SEA=XPSVC(IFL,-1)
21777           VAL=XPSVC(IFL,0)
21778           CMP=0D0
21779           DO 380 IVC=1,NVC(JS,IFL)
21780             CMP=CMP+XPSVC(IFL,IVC)
21781   380     CONTINUE
21782  
21783 C...Decide (Extra factor x cancels in the dvision).
21784           RVCS=PYR(0)*(SEA+VAL+CMP)
21785           IVNOW=1
21786   390     IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21787 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21788             IVNOW=0
21789             IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21790             IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21791             IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21792             IF(KFIVAL(JS,1).EQ.0) THEN
21793               IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21794               IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21795               IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21796      &        (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21797             ELSE
21798               DO 400 I1=1,NMI(JS)
21799                 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21800      &            IVNOW=IVNOW-1
21801   400         CONTINUE
21802             ENDIF
21803             IF(IVNOW.EQ.0) GOTO 390
21804 C...Mark valence.
21805             IMI(JS,MINT(31),2)=0
21806 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21807             IF(KFIVAL(JS,1).EQ.0) THEN
21808               IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21809                 KFIVAL(JS,1)=IFL
21810                 KFIVAL(JS,2)=-IFL
21811               ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21812                 KFIVAL(JS,1)=IFL
21813                 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21814                 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21815               ENDIF
21816             ENDIF
21817  
21818           ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21819 C...If sea, add opposite sign companion parton. Store X and I.
21820             NVC(JS,-IFL)=NVC(JS,-IFL)+1
21821             XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21822 C...Set pointer to companion
21823             IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21824           ELSE
21825 C...If companion, decide which one.
21826             CMPSUM=VAL+SEA
21827             ISEL=0
21828   410       ISEL=ISEL+1
21829             CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21830             IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21831 C...Find original sea (anti-)quark:
21832             IASSOC=0
21833             DO 420 I1=1,NMI(JS)
21834               IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21835               IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21836                 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21837                 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21838               ENDIF
21839   420       CONTINUE
21840 C...Change X to what associated companion had, so that the correct
21841 C...amount of momentum can be subtracted from the companion sum below.
21842             X=XASSOC(JS,IFL,ISEL)
21843 C...Mark companion read.
21844             XASSOC(JS,IFL,ISEL)=0D0
21845           ENDIF
21846  430    CONTINUE
21847  
21848 C...Global statistics.
21849         MINT(351)=MINT(351)+1
21850         VINT(351)=VINT(351)+PT
21851         IF (MINT(351).EQ.1) VINT(356)=PT
21852  
21853 C...Update remaining energy and other counters.
21854         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21855           CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21856           MINT(51)=1
21857           RETURN
21858         ENDIF
21859         NMI(1)=NMI(1)+1
21860         NMI(2)=NMI(2)+1
21861         VINT(151)=VINT(151)+VINT(41)
21862         VINT(152)=VINT(152)+VINT(42)
21863         VINT(143)=VINT(143)-VINT(141)
21864         VINT(144)=VINT(144)-VINT(142)
21865  
21866 C...Iterate, with more interactions allowed.
21867         IF(MINT(31).LT.240) GOTO 240
21868  440    CONTINUE
21869  
21870 C...Restore saved quantities for hardest interaction.
21871         MINT(1)=ISUBSV
21872         MINT(13)=M13SV
21873         MINT(14)=M14SV
21874         MINT(15)=M15SV
21875         MINT(16)=M16SV
21876         MINT(21)=M21SV
21877         MINT(22)=M22SV
21878         DO 450 J=11,80
21879           VINT(J)=VINTSV(J)
21880   450   CONTINUE
21881         VINT(141)=V141SV
21882         VINT(142)=V142SV
21883  
21884       ENDIF
21885  
21886 C...Format statements for printout.
21887  5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21888      &'actions for MSTP(82) =',I2,' ******')
21889  5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21890      &D9.2,' mb: rejected')
21891  5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21892      &D9.2,' mb: accepted')
21893  
21894       RETURN
21895       END
21896  
21897 C*********************************************************************
21898  
21899 C...PYMIHK
21900 C...Finds left-behind remnant flavour content and hooks up
21901 C...the colour flow between the hard scattering and remnants
21902  
21903       SUBROUTINE PYMIHK
21904  
21905 C...Double precision and integer declarations.
21906       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21907       IMPLICIT INTEGER(I-N)
21908       INTEGER PYK,PYCHGE,PYCOMP
21909 C...The event record
21910       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21911 C...Parameters
21912       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21913       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21914       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21915       COMMON/PYINT1/MINT(400),VINT(400)
21916 C...The common block of dangling ends
21917       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21918      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21919      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
21920       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21921 C...Local variables
21922       PARAMETER (NERSIZ=4000)
21923       COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21924      &     ,MACCPT
21925       COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21926       SAVE /PYCBLS/,/PYCTAG/
21927       DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21928      &     ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21929       DATA NERRPR/0/
21930       SAVE NERRPR
21931       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)
21932  
21933 C...Set up error checkers
21934       IBOOST=0
21935  
21936 C...Initialize colour arrays: MCO (Original) and MCT (New)
21937       DO 110 I=MINT(84)+1,NERSIZ
21938         DO 100 JC=1,2
21939           MCT(I,JC)=0
21940           MCO(I,JC)=0
21941   100   CONTINUE
21942 C...Also zero colour tracing information, if existed.
21943         IF (I.LE.N) THEN
21944           K(I,4)=MOD(K(I,4),MSTU(5)**2)
21945           K(I,5)=MOD(K(I,5),MSTU(5)**2)
21946         ENDIF
21947   110 CONTINUE
21948  
21949 C...Initialize colour tag collapse arrays:
21950 C...JCCO (Original) and JCCN (New).
21951       DO 130 MG=MINT(84)+1,NERSIZ
21952         DO 120 JC=1,2
21953           JCCO(MG,JC)=0
21954           JCCN(MG,JC)=0
21955   120   CONTINUE
21956   130 CONTINUE
21957  
21958 C...Zero gluon insertion array
21959       DO 150 IM=1,1000
21960         DO 140 J=1,3
21961           INSR(IM,J)=0
21962   140   CONTINUE
21963   150 CONTINUE
21964  
21965 C...Compute hard scattering system rapidities
21966       IF (MSTP(89).EQ.1) THEN
21967         DO 160 IM=1,240
21968           IF (IM.LE.MINT(31)) THEN
21969             YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21970           ELSE
21971 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21972             YMI(IM)=100D0
21973           ENDIF
21974   160   CONTINUE
21975       ENDIF
21976  
21977 C...Treat each side separately
21978       DO 290 JS=1,2
21979  
21980 C...Initialize side.
21981         NG(JS)=0
21982         JV=0
21983         KFS=ISIGN(1,MINT(10+JS))
21984  
21985 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21986         IF(KFIVAL(JS,1).EQ.0) THEN
21987           IF(MINT(10+JS).EQ.111) THEN
21988             KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21989             KFIVAL(JS,2)=-KFIVAL(JS,1)
21990           ELSEIF(MINT(10+JS).EQ.22) THEN
21991             PYRKF=PYR(0)
21992             KFIVAL(JS,1)=1
21993             IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21994             IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21995             IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21996             KFIVAL(JS,2)=-KFIVAL(JS,1)
21997           ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21998             IF(PYR(0).GT.0.5D0) THEN
21999               KFIVAL(JS,1)=1
22000               KFIVAL(JS,2)=-3
22001             ELSE
22002               KFIVAL(JS,1)=3
22003               KFIVAL(JS,2)=-1
22004             ENDIF
22005           ENDIF
22006         ENDIF
22007  
22008 C...Initialize beam remnant sea and valence content flavour by flavour.
22009         NVSUM(JS)=0
22010         NBRTOT(JS)=0
22011         DO 210 JFA=1,6
22012 C...Count up original number of JFA valence quarks and antiquarks.
22013           NVALQ=0
22014           NVALQB=0
22015           NSEA=0
22016           DO 170 J=1,3
22017             IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
22018             IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
22019   170     CONTINUE
22020           NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
22021 C...Subtract kicked out valence and determine sea from flavour cons.
22022           DO 180 IM=1,NMI(JS)
22023             IFL = K(IMI(JS,IM,1),2)
22024             IFA = IABS(IFL)
22025             IFS = ISIGN(1,IFL)
22026             IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22027 C...Subtract K.O. valence quark from remainder.
22028               NVALQ=NVALQ-1
22029               JV=NVSUM(JS)-NVALQ-NVALQB
22030               IV(JS,JV)=IMI(JS,IM,1)
22031             ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22032 C...Subtract K.O. valence antiquark from remainder.
22033               NVALQB=NVALQB-1
22034               JV=NVSUM(JS)-NVALQ-NVALQB
22035               IV(JS,JV)=IMI(JS,IM,1)
22036             ELSEIF (IFA.EQ.JFA) THEN
22037 C...Outside sea without companion: add opposite sea flavour inside.
22038               IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
22039             ENDIF
22040   180     CONTINUE
22041 C...Check if space left in PYJETS for additional BR flavours
22042           NFLSUM=IABS(NSEA)+NVALQ+NVALQB
22043           NBRTOT(JS)=NBRTOT(JS)+NFLSUM
22044           IF (N+NFLSUM+1.GT.MSTU(4)) THEN
22045             CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
22046             MINT(51)=1
22047             RETURN
22048           ENDIF
22049 C...Add required val+sea content to beam remnant.
22050           IF (NFLSUM.GT.0) THEN
22051             DO 200 IA=1,NFLSUM
22052 C...Insert beam remnant quark as p.t. symbolic parton in ER.
22053               N=N+1
22054               DO 190 IX=1,5
22055                 K(N,IX)=0
22056                 P(N,IX)=0D0
22057                 V(N,IX)=0D0
22058   190         CONTINUE
22059               K(N,1)=3
22060               K(N,2)=ISIGN(JFA,NSEA)
22061               IF (IA.LE.NVALQ) K(N,2)=JFA
22062               IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
22063               K(N,3)=MINT(83)+JS
22064 C...Also update NMI, IMI, and IV arrays.
22065               NMI(JS)=NMI(JS)+1
22066               IMI(JS,NMI(JS),1)=N
22067               IMI(JS,NMI(JS),2)=-1
22068               IF (IA.LE.NVALQ+NVALQB) THEN
22069                 IMI(JS,NMI(JS),2)=0
22070                 JV=JV+1
22071                 IV(JS,JV)=IMI(JS,NMI(JS),1)
22072               ENDIF
22073   200       CONTINUE
22074           ENDIF
22075   210   CONTINUE
22076  
22077         IM=0
22078   220   IM=IM+1
22079         IF (IM.LE.NMI(JS)) THEN
22080           IF (K(IMI(JS,IM,1),2).EQ.21) THEN
22081             NG(JS)=NG(JS)+1
22082 C...Add fictitious parent gluons for companion pairs.
22083           ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
22084 C...Randomly assign companions to sea quarks which have none.
22085             IF (IMI(JS,IM,2).LT.0) THEN
22086               IMC=PYR(0)*NMI(JS)
22087   230         IMC=MOD(IMC,NMI(JS))+1
22088               IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
22089               IF (IMI(JS,IMC,2).GE.0) GOTO 230
22090               IMI(JS, IM,2) = IMI(JS,IMC,1)
22091               IMI(JS,IMC,2) = IMI(JS, IM,1)
22092             ENDIF
22093 C...Add fictitious parent gluon
22094             N=N+1
22095             DO 240 IX=1,5
22096               K(N,IX)=0
22097               P(N,IX)=0D0
22098               V(N,IX)=0D0
22099   240       CONTINUE
22100             K(N,1)=14
22101             K(N,2)=21
22102             K(N,3)=MINT(83)+JS
22103 C...Set gluon (anti-)colour daughter pointers
22104             K(N,4)=IMI(JS, IM,1)
22105             K(N,5)=IMI(JS, IM,2)
22106 C...Set quark (anti-)colour parent pointers
22107             K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
22108             K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
22109 C...Add gluon to IMI
22110             NMI(JS)=NMI(JS)+1
22111             IMI(JS,NMI(JS),1)=N
22112             IMI(JS,NMI(JS),2)=0
22113           ENDIF
22114           GOTO 220
22115         ENDIF
22116  
22117 C...If incoming (anti-)baryon, insert inside (anti-)junction.
22118 C...Set up initial v-v-j-v configuration. Otherwise set up
22119 C...mesonic v-vbar configuration
22120         IF (IABS(MINT(10+JS)).GT.1000) THEN
22121 C...Determine junction type (1: B=1 2: B=-1)
22122           ITJUNC(JS) = (3-KFS)/2
22123 C...Insert junction.
22124           N=N+1
22125           DO 250 IX=1,5
22126             K(N,IX)=0
22127             P(N,IX)=0D0
22128             V(N,IX)=0D0
22129   250     CONTINUE
22130 C...Set special junction codes:
22131           K(N,1)=42
22132           K(N,2)=88
22133 C...Set parent to side.
22134           K(N,3)=MINT(83)+JS
22135           K(N,4)=ITJUNC(JS)*MSTU(5)
22136           K(N,5)=0
22137 C...Connect valence quarks to junction.
22138           MOUT(JS)=0
22139           MANTI=ITJUNC(JS)-1
22140 C...Set (anti)colour mother = junction.
22141           DO 260 JV=1,3
22142             K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22143      &           +MSTU(5)*N
22144 C...Keep track of partons adjacent to junction:
22145             JST(JS,JV)=IV(JS,JV)
22146   260     CONTINUE
22147         ELSE
22148 C...Mesons: set up initial q-qbar topology
22149           ITJUNC(JS)=0
22150           IF (K(IV(JS,1),2).GT.0) THEN
22151             IQ=IV(JS,1)
22152             IQBAR=IV(JS,2)
22153           ELSE
22154             IQ=IV(JS,2)
22155             IQBAR=IV(JS,1)
22156           ENDIF
22157           IV(JS,3)=0
22158           JST(JS,1)=IQ
22159           JST(JS,2)=IQBAR
22160           JST(JS,3)=0
22161           K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22162           K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22163 C...Special for mesons. Insert gluon if BR empty.
22164           IF (NBRTOT(JS).EQ.0) THEN
22165             N=N+1
22166             DO 270 IX=1,5
22167               K(N,IX)=0
22168               P(N,IX)=0D0
22169               V(N,IX)=0D0
22170   270       CONTINUE
22171             K(N,1)=3
22172             K(N,2)=21
22173             K(N,3)=MINT(83)+JS
22174             K(N,4)=0
22175             K(N,5)=0
22176             NBRTOT(JS)=1
22177             NG(JS)=NG(JS)+1
22178 C...Add gluon to IMI
22179             NMI(JS)=NMI(JS)+1
22180             IMI(JS,NMI(JS),1)=N
22181             IMI(JS,NMI(JS),2)=0
22182           ENDIF
22183           MOUT(JS)=0
22184         ENDIF
22185  
22186 C...Count up number of valence quarks outside BR.
22187         DO 280 JV=1,3
22188           IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
22189      &         MOUT(JS)=MOUT(JS)+1
22190   280   CONTINUE
22191  
22192   290 CONTINUE
22193  
22194 C...Now both sides have been prepared in an initial vvjv (baryonic) or
22195 C...v(g)vbar (mesonic) configuration.
22196  
22197 C...Create colour line tags starting from initiators.
22198       NCT=0
22199       DO 320 IM=1,MINT(31)
22200 C...Consider each side in turn.
22201         DO 310 JS=1,2
22202           I1=IMI(JS,IM,1)
22203           I2=IMI(3-JS,IM,1)
22204           DO 300 JCS=4,5
22205             IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
22206      &           GOTO 300
22207             IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
22208  
22209             KCS=JCS
22210             CALL PYCTTR(I1,KCS,I2)
22211             IF(MINT(51).NE.0) RETURN
22212  
22213   300     CONTINUE
22214   310   CONTINUE
22215   320 CONTINUE
22216  
22217       DO 340 JS=1,2
22218 C...Create colour tags for beam remnant partons.
22219         DO 330 IM=MINT(31)+1,NMI(JS)
22220           IP=IMI(JS,IM,1)
22221           IF (K(IP,2).NE.21) THEN
22222             JC=(3-ISIGN(1,K(IP,2)))/2
22223             IF (MCT(IP,JC).EQ.0) THEN
22224               NCT=NCT+1
22225               MCT(IP,JC)=NCT
22226             ENDIF
22227           ELSE
22228 C...Gluons
22229             ICD=K(IP,4)
22230             IAD=K(IP,5)
22231             IF (ICD.NE.0) THEN
22232 C...Fictituous gluons just inherit from their quark daughters.
22233               ICC=MCT(ICD,1)
22234               IAC=MCT(IAD,2)
22235             ELSE
22236 C...Real beam remnant gluons get their own colours
22237               ICC=NCT+1
22238               IAC=NCT+2
22239               NCT=NCT+2
22240             ENDIF
22241             MCT(IP,1)=ICC
22242             MCT(IP,2)=IAC
22243           ENDIF
22244   330   CONTINUE
22245   340 CONTINUE
22246  
22247 C...Create colour tags for colour lines which are detached from the
22248 C...initial state.
22249  
22250       DO 360 MQGST=1,2
22251         DO 350 I=MINT(84)+1,N
22252  
22253 C...Look for coloured string endpoint, or (later) leftover gluon.
22254           IF (K(I,1).NE.3) GOTO 350
22255           KC=PYCOMP(K(I,2))
22256           IF(KC.EQ.0) GOTO 350
22257           KQ=KCHG(KC,2)
22258           IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
22259  
22260 C...Pick up loose string end with no previous tag.
22261           KCS=4
22262           IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
22263           IF(MCT(I,KCS-3).NE.0) GOTO 350
22264  
22265           CALL PYCTTR(I,KCS,I)
22266           IF(MINT(51).NE.0) RETURN
22267  
22268   350   CONTINUE
22269   360 CONTINUE
22270  
22271 C...Store original colour tags
22272       DO 370 I=MINT(84)+1,N
22273         MCO(I,1)=MCT(I,1)
22274         MCO(I,2)=MCT(I,2)
22275   370 CONTINUE
22276  
22277 C...Iteratively add gluons to already existing string pieces, enforcing
22278 C...various possible orderings, and rejecting insertions that would give
22279 C...rise to singlet gluons.
22280 C...<kappa tau> normalization.
22281       RM0=1.5D0
22282       MRETRY=0
22283       PARP80=PARP(80)
22284  
22285 C...Set up simplified kinematics.
22286 C...Boost hard interaction systems.
22287       IBOOST=IBOOST+1
22288       DO 380 IM=1,MINT(31)
22289         BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22290         CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22291   380 CONTINUE
22292 C...Assign preliminary beam remnant momenta.
22293       DO 390 I=MINT(53)+1,N
22294         JS=K(I,3)
22295         P(I,1)=0D0
22296         P(I,2)=0D0
22297         IF (K(I,2).NE.88) THEN
22298           P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
22299           P(I,3)=P(I,4)
22300           IF (JS.EQ.2) P(I,3)=-P(I,3)
22301         ELSE
22302 C...Junctions are wildcards for the present.
22303           P(I,4)=0D0
22304           P(I,3)=0D0
22305         ENDIF
22306   390 CONTINUE
22307  
22308 C...Reset colour processing information.
22309   400 DO 410 I=MINT(84)+1,N
22310         K(I,4)=MOD(K(I,4),MSTU(5)**2)
22311         K(I,5)=MOD(K(I,5),MSTU(5)**2)
22312   410 CONTINUE
22313  
22314       NCC=0
22315       DO 430 JS=1,2
22316 C...If meson,  without gluon in BR, collapse q-qbar colour tags:
22317         IF (ITJUNC(JS).EQ.0) THEN
22318           JC1=MCT(JST(JS,1),1)
22319           JC2=MCT(JST(JS,2),2)
22320           NCC=NCC+1
22321           JCCO(NCC,1)=MAX(JC1,JC2)
22322           JCCO(NCC,2)=MIN(JC1,JC2)
22323 C...Collapse colour tags in event record
22324           DO 420 I=MINT(84)+1,N
22325             IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
22326             IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
22327   420     CONTINUE
22328         ENDIF
22329   430 CONTINUE
22330  
22331   440 JS=1
22332       IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
22333       IF (NG(JS).GT.0) THEN
22334         NOPT=0
22335         RLOPT=1D9
22336 C...Start at random gluon (optimizes speed for random attachments)
22337         NMGL=0
22338         IMGL=PYR(0)*NMI(JS)+1
22339   450   IMGL=MOD(IMGL,NMI(JS))+1
22340         NMGL=NMGL+1
22341 C...Only loop through NMI once (with upper limit to save time)
22342         IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
22343           IGL  = IMI(JS,IMGL,1)
22344 C...If not gluon or if already connected, try next.
22345           IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
22346      &         .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
22347 C...Now loop through all possible insertions of this gluon.
22348           NMP1=0
22349           IMP1=PYR(0)*NMI(JS)+1
22350   460     IMP1=MOD(IMP1,NMI(JS))+1
22351           NMP1=NMP1+1
22352           IF (IMP1.EQ.IMGL) GOTO 460
22353 C...Only loop through NMI once (with upper limit to save time).
22354           IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
22355             IP1  = IMI(JS,IMP1,1)
22356 C...Try both colour mother and colour anti-mother.
22357 C...Randomly select which one to try first.
22358             NANTI=0
22359             MANTI=PYR(0)*2
22360   470       MANTI=MOD(MANTI+1,2)
22361             NANTI=NANTI+1
22362             IF (NANTI.LE.2) THEN
22363               IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
22364 C...Reject if no appropriate mother (or if mother is fictitious
22365 C...parent gluon.)
22366               IF (IP2.LE.0) GOTO 470
22367               IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
22368 C...Also reject if this link has already been tried.
22369               IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22370               IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22371 C...Set flag to indicate that this link has now been tried for this
22372 C...gluon. IP2 may be junction, which has several mothers.
22373               K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
22374               IF (K(IP2,2).NE.88) THEN
22375                 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
22376               ENDIF
22377  
22378 C...JCG1: Original colour tag of gluon on IP1 side
22379 C...JCG2: Original colour tag of gluon on IP2 side
22380 C...JCP1: Original colour tag of IP1 on gluon side
22381 C...JCP2: Original colour tag of IP2 on gluon side.
22382               JCG1=MCO(IGL,2-MANTI)
22383               JCG2=MCO(IGL,1+MANTI)
22384               JCP1=MCO(IP1,1+MANTI)
22385               JCP2=MCO(IP2,2-MANTI)
22386  
22387               CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
22388 C...Reject gluon attachments that give rise to singlet gluons.
22389               IF (MACCPT.EQ.0) GOTO 470
22390  
22391 C...Update colours
22392               JCG1=MCT(IGL,2-MANTI)
22393               JCG2=MCT(IGL,1+MANTI)
22394               JCP1=MCT(IP1,1+MANTI)
22395               JCP2=MCT(IP2,2-MANTI)
22396  
22397 C...Select whether to accept this insertion
22398               IF (MSTP(89).EQ.0) THEN
22399 C...Random insertions: no measure.
22400                 RL=1D0
22401 C...For random ordering, we want to suppress beam remnant breakups
22402 C...already at this point.
22403                 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
22404      &               .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
22405                   NMP1=0
22406                   NMGL=0
22407                   GOTO 470
22408                 ENDIF
22409               ELSEIF (MSTP(89).EQ.1) THEN
22410 C...Rapidity ordering:
22411 C...YGL = Rapidity of gluon.
22412                 YGL=YMI(IMGL)
22413 C...If fictitious gluon
22414                 IF (YGL.EQ.100D0) THEN
22415                   YGL=(3-2*JS)*100D0
22416                   IDA1=MOD(K(IGL,4),MSTU(5))
22417                   IDA2=MOD(K(IGL,5),MSTU(5))
22418                   DO 480 IMT=1,NMI(JS)
22419 C...Select (arbitrarily) the most central daughter.
22420                     IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22421      &                   THEN
22422                       IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
22423                     ENDIF
22424   480             CONTINUE
22425                 ENDIF
22426 C...YP1 = Rapidity IP1
22427                 YP1=YMI(IMP1)
22428 C...If fictitious gluon
22429                 IF (YP1.EQ.100D0) THEN
22430                   YP1=(3-2*JS)*YP1
22431                   IDA1=MOD(K(IP1,4),MSTU(5))
22432                   IDA2=MOD(K(IP1,5),MSTU(5))
22433                   DO 490 IMT=1,NMI(JS)
22434 C...Select (arbitrarily) the most central daughter.
22435                     IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22436      &                   THEN
22437                       IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
22438                     ENDIF
22439   490             CONTINUE
22440                 ENDIF
22441 C...YP2 = Rapidity of mother system
22442                 IF (K(IP2,2).NE.88) THEN
22443                   DO 500 IMT=1,NMI(JS)
22444                     IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
22445   500             CONTINUE
22446 C...If fictitious gluon
22447                   IF (YP2.EQ.100D0) THEN
22448                     YP2=(3-2*JS)*YP2
22449                     IDA1=MOD(K(IP2,4),MSTU(5))
22450                     IDA2=MOD(K(IP2,5),MSTU(5))
22451                     DO 510 IMT=1,NMI(JS)
22452 C...Select (arbitrarily) the most central daughter.
22453                       IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
22454      &                     ) THEN
22455                         IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
22456                       ENDIF
22457   510               CONTINUE
22458                   ENDIF
22459 C...Assign (arbitrarily) 100D0 to junction also
22460                 ELSE
22461                   YP2=(3-2*JS)*100D0
22462                 ENDIF
22463                 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
22464               ELSEIF (MSTP(89).EQ.2) THEN
22465 C...Lambda ordering:
22466 C...Compute lambda measure for this insertion.
22467                 RL=1D0
22468                 DO 520 IST=1,6
22469                   ISTR(IST)=0
22470   520           CONTINUE
22471 C...If IP2 is junction, not caught below.
22472                 IF (JCP2.EQ.0) THEN
22473                   ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22474 C...Anti-junction is colour endpoint et vv., always on JCG2.
22475                   ISTR(5-ITJU)=IP2
22476                 ENDIF
22477                 DO 530 I=MINT(84)+1,N
22478                   IF (K(I,1).LT.10) THEN
22479 C...The new string pieces
22480                     IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22481                     IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22482                     IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22483                     IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22484                   ENDIF
22485   530           CONTINUE
22486 C...Also identify junctions as string endpoints.
22487                 DO 540 I=MINT(84)+1,N
22488                   ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22489                   IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22490 C...Find partons adjacent to junctions.
22491                   IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22492                     IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22493      &                  .EQ.0) ISTR(2) = ICMO
22494                     IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22495      &                  .EQ.0) ISTR(4) = ICMO
22496                   ENDIF
22497                   IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22498                     IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22499      &                  .EQ.0) ISTR(1) = IAMO
22500                     IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22501      &                  .EQ.0) ISTR(3) = IAMO
22502                   ENDIF
22503   540           CONTINUE
22504 C...The old string piece
22505                 ISTR(5)=ISTR(1+2*MANTI)
22506                 ISTR(6)=ISTR(4-2*MANTI)
22507                 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22508      &              ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22509 C...If one or more of the colour tags for this connection is/are still
22510 C...dangling, skip this attempt for the time being. 
22511                   RL=1D6
22512                 ELSE
22513                   RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22514      &                ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22515                   RL=LOG(RL)
22516                 ENDIF
22517               ENDIF
22518 C...Allow some breadth to speed things up.
22519               IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22520                 NOPT=NOPT+1
22521               ELSEIF (RL.GT.RLOPT) THEN
22522                 GOTO 470
22523               ELSE
22524                 NOPT=1
22525                 RLOPT=RL
22526               ENDIF
22527 C...INSR(NOPT,1)=Gluon colour mother
22528 C...INSR(NOPT,2)=Gluon
22529 C...INSR(NOPT,3)=Gluon anticolour mother
22530               IF (NOPT.GT.1000) GOTO 470
22531               INSR(NOPT,1+2*MANTI)=IP2
22532               INSR(NOPT,2)=IGL
22533               INSR(NOPT,3-2*MANTI)=IP1
22534               IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22535             ENDIF
22536             IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22537           ENDIF
22538 C...Reset link test information.
22539           DO 550 I=MINT(84)+1,N
22540             K(I,4)=MOD(K(I,4),MSTU(5)**2)
22541             K(I,5)=MOD(K(I,5),MSTU(5)**2)
22542   550     CONTINUE
22543           IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22544         ENDIF
22545 C...Now we have a list of best gluon insertions, none of which cause
22546 C...singlets to arise. If list is empty, try again a few times. Note:
22547 C...this should never happen if we have a meson with a gluon inserted
22548 C...in the beam remnant, since that breaks up the colour line.
22549         IF (NOPT.EQ.0) THEN
22550 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22551 C...just means we happened to start with trying a bad sequence.
22552           PARP80=1D0
22553           IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22554      &         .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22555             MRETRY=MRETRY+1
22556             DO 590 JS=1,2
22557               IF (ITJUNC(JS).NE.0) THEN
22558                 JST(JS,1)=IV(JS,1)
22559                 JST(JS,2)=IV(JS,2)
22560                 JST(JS,3)=IV(JS,3)
22561 C...Reset valence quark parent pointers
22562                 DO 560 I=MINT(53)+1,N
22563                   IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22564   560           CONTINUE
22565                 MANTI=ITJUNC(JS)-1
22566 C...Set (anti)colour mother = junction.
22567                 DO 570 JV=1,3
22568                   K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22569      &                 +MSTU(5)*IJU
22570   570           CONTINUE
22571               ELSE
22572 C...Same for mesons. JST unchanged, so needn't be restored.
22573                 IQ=JST(JS,1)
22574                 IQBAR=JST(JS,2)
22575                 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22576                 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22577               ENDIF
22578 C...Also reset gluon parent pointers.
22579               NG(JS)=0
22580               DO 580 IM=1,NMI(JS)
22581                 I=IMI(JS,IM,1)
22582                 IF (K(I,2).EQ.21) THEN
22583                   K(I,4)=MOD(K(I,4),MSTU(5))
22584                   K(I,5)=MOD(K(I,5),MSTU(5))
22585                   NG(JS)=NG(JS)+1
22586                 ENDIF
22587   580         CONTINUE
22588   590       CONTINUE
22589 C...Reset colour tags
22590             DO 600 I=MINT(84)+1,N
22591               MCT(I,1)=MCO(I,1)
22592               MCT(I,2)=MCO(I,2)
22593   600       CONTINUE
22594             GOTO 400
22595           ELSE
22596             IF(NERRPR.LT.5) THEN
22597               NERRPR=NERRPR+1
22598               CALL PYLIST(4)
22599               CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22600               WRITE(MSTU(11),*) 'NG:', NG,'   MOUT:', MOUT(JS)
22601             ENDIF
22602 C...Kill event and start another.
22603             MINT(51)=1
22604             RETURN
22605           ENDIF
22606         ELSE
22607 C...Select between insertions, suppressing insertions wholly in the BR.
22608           IIN=PYR(0)*NOPT+1
22609   610     IIN=MOD(IIN,NOPT)+1
22610           IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22611      &         .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22612         ENDIF
22613  
22614 C...Now we know which gluon to insert where. Colour tags in JCCO and
22615 C...colour connection information should be updated, NG(JS) should be
22616 C...counted down, and a new loop performed if there are still gluons
22617 C...left on any side.
22618         ICM=INSR(IIN,1)
22619         IACM=INSR(IIN,3)
22620         IGL=INSR(IIN,2)
22621 C...JCG : Original gluon colour tag
22622 C...JCAG: Original gluon anticolour tag.
22623 C...JCM : Original anticolour tag of gluon colour mother
22624 C...JACM: Original colour tag of gluon anticolour mother
22625         JCG=MCO(IGL,1)
22626         JCM=MCO(ICM,2)
22627         JACG=MCO(IGL,2)
22628         JACM=MCO(IACM,1)
22629  
22630         CALL PYMIHG(JACM,JACG,JCM,JCG)
22631         IF (MACCPT.EQ.0) THEN
22632           IF(NERRPR.LT.5) THEN
22633             NERRPR=NERRPR+1
22634             CALL PYLIST(4)
22635             CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22636             WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22637           ENDIF
22638 C...Kill event and start another.
22639           MINT(51)=1
22640           RETURN
22641         ELSE
22642 C...If everything went fine, store new JCCN in JCCO.
22643           NCC=NCC+1
22644           DO 620 ICC=1,NCC
22645             JCCO(ICC,1)=JCCN(ICC,1)
22646             JCCO(ICC,2)=JCCN(ICC,2)
22647   620     CONTINUE
22648         ENDIF
22649  
22650 C...One gluon attached is counted as equivalent to one end outside.
22651         MOUT(JS)=1
22652 C...Set IGL colour mother = ICM.
22653         K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22654 C...Set ICM anticolour mother = IGL colour.
22655         IF (K(ICM,2).NE.88) THEN
22656           K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22657         ELSE
22658 C...If ICM is junction, just update JST array for now.
22659           DO 630 MSJ=1,3
22660             IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22661   630     CONTINUE
22662         ENDIF
22663 C...Set IGL anticolour mother = IACM.
22664         K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22665 C...Set IACM anticolour mother = IGL anticolour.
22666         IF (K(IACM,2).NE.88) THEN
22667           K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22668         ELSE
22669 C...If IACM is junction, just update JST array for now.
22670           DO 640 MSJ=1,3
22671             IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22672   640     CONTINUE
22673         ENDIF
22674 C...Count down # unconnected gluons.
22675         NG(JS)=NG(JS)-1
22676       ENDIF
22677       IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22678  
22679       DO 840 JS=1,2
22680 C...Collapse fictitious gluons.
22681         DO 670 IGL=MINT(53)+1,N
22682           IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22683      &         K(IGL,1).EQ.14) THEN
22684             ICM=K(IGL,4)/MSTU(5)
22685             IAM=K(IGL,5)/MSTU(5)
22686             ICD=MOD(K(IGL,4),MSTU(5))
22687             IAD=MOD(K(IGL,5),MSTU(5))
22688 C...Set gluon daughters pointing to gluon mothers
22689             K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22690             K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22691 C...Set gluon mothers pointing to gluon daughters.
22692             IF (K(ICM,2).NE.88) THEN
22693               K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22694             ELSE
22695 C...Special case: mother=junction. Just update JST array for now.
22696               DO 650 MSJ=1,3
22697                 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22698   650         CONTINUE
22699             ENDIF
22700             IF (K(IAM,2).NE.88) THEN
22701               K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22702             ELSE
22703               DO 660 MSJ=1,3
22704                 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22705   660         CONTINUE
22706             ENDIF
22707           ENDIF
22708   670   CONTINUE
22709  
22710 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22711         IM=NMI(JS)+1
22712   680   IM=IM-1
22713         IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22714         IF (IM.GT.MINT(31)) THEN
22715           NMI(JS)=NMI(JS)-1
22716           DO 690 IMR=IM,NMI(JS)
22717             IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22718             IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22719   690     CONTINUE
22720           GOTO 680
22721         ENDIF
22722  
22723 C...Finally, connect junction.
22724         IF (ITJUNC(JS).NE.0) THEN
22725           DO 700 I=MINT(53)+1,N
22726             IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22727   700     CONTINUE
22728 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22729           NBRJQ =0
22730           NBRVQ =0
22731           DO 720 MSJ=1,3
22732             IDQ(MSJ)=0
22733 C...Find jq with no glue inbetween inside beam remnant.
22734             IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22735      &           THEN
22736               NBRJQ=NBRJQ+1
22737 C...Set IDQ = -I if q non-valence and = +I if q valence.
22738               IDQ(NBRJQ)=-JST(JS,MSJ)
22739               DO 710 JV=1,3
22740                 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22741                   IDQ(NBRJQ)=JST(JS,MSJ)
22742                   NBRVQ=NBRVQ+1
22743                 ENDIF
22744   710         CONTINUE
22745             ENDIF
22746             I12=MOD(MSJ+1,2)
22747             I45=5
22748             IF (MSJ.EQ.3) I45=4
22749             K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22750   720     CONTINUE
22751  
22752 C...Check if diquark can be formed.
22753           IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22754      &         .GE.1)) THEN
22755 C...If there is less than 2 valence quarks connected to junction
22756 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22757             IF (NBRVQ.LE.1) THEN
22758               NDIQ=NBRVQ
22759   730         JFLIP=NBRJQ*PYR(0)+1
22760               IF (IDQ(JFLIP).LT.0) THEN
22761                 IDQ(JFLIP)=-IDQ(JFLIP)
22762                 NDIQ=NDIQ+1
22763               ENDIF
22764               IF (NDIQ.LE.1) GOTO 730
22765             ENDIF
22766 C...Place selected quarks first in IDQ, ordered in flavour.
22767             DO 740 JDQ=1,3
22768               IF (IDQ(JDQ).LE.0) THEN
22769                 ITEMP1  = IDQ(JDQ)
22770                 IDQ(JDQ)= IDQ(3)
22771                 IDQ(3)  = -ITEMP1
22772                 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22773                   ITEMP1  = IDQ(1)
22774                   IDQ(1)  = IDQ(2)
22775                   IDQ(2)  = ITEMP1
22776                 ENDIF
22777               ENDIF
22778   740       CONTINUE
22779 C...Choose diquark spin.
22780             IF (NBRVQ.EQ.2) THEN
22781 C...If the selected quarks are both valence, we may use SU(6) rules
22782 C...to figure out which spin the diquark has, by a subdivision of the
22783 C...original beam hadron into the selected diquark system plus a kicked
22784 C...out quark, IKO.
22785               JKO=6
22786               DO 760 JDQ=1,2
22787                 DO 750 JV=1,3
22788                   IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22789   750           CONTINUE
22790   760         CONTINUE
22791               IKO=IV(JS,JKO)
22792               CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22793             ELSE
22794 C...If one or more of the selected quarks are not valence, we cannot use
22795 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22796 C...flavours of the diquark already selected, we assume for now
22797 C...50:50 spin-1:spin-0 (where spin-0 possible).
22798               KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22799               IS=3
22800               IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22801      &           (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22802               KFDQ=KFDQ+ISIGN(IS,KFDQ)
22803             ENDIF
22804  
22805 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22806 C...Note: third quark can per definition not also be valence,
22807 C...therefore we can only do this if we are allowed to use sea quarks.
22808   770       IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22809               NTRY=0
22810   780         NTRY=NTRY+1
22811               CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22812               IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22813                 GOTO 780
22814               ELSEIF(NTRY.GT.100) THEN
22815 C...If no baryon can be found, give up and form diquark.
22816                 IDQ(3)=0
22817                 GOTO 770
22818               ELSE
22819 C...Replace junction by baryon.
22820                 K(IJU,1)=1
22821                 K(IJU,2)=KFBAR
22822                 K(IJU,3)=MINT(83)+JS
22823                 K(IJU,4)=0
22824                 K(IJU,5)=0
22825                 P(IJU,5)=PYMASS(KFBAR)
22826                 DO 790 MSJ=1,3
22827 C...Prepare removal of participating quarks from ER.
22828                   K(JST(JS,MSJ),1)=-1
22829   790           CONTINUE
22830               ENDIF
22831             ELSE
22832 C...If collapse to baryon not possible or not allowed, replace junction
22833 C...by diquark. This way, collapsed gluons that were pointing at the
22834 C...junction will now point (correctly) at diquark.
22835               MANTI=ITJUNC(JS)-1
22836               K(IJU,1)=3
22837               K(IJU,2)=KFDQ
22838               K(IJU,3)=MINT(83)+JS
22839               K(IJU,4)=0
22840               K(IJU,5)=0
22841               DO 800 MSJ=1,3
22842                 IP=JST(JS,MSJ)
22843                 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22844                   K(IJU,4+MANTI)=0
22845                   K(IJU,5-MANTI)=IP*MSTU(5)
22846                   K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22847      &                 MSTU(5)*IJU
22848                   MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22849                 ELSE
22850 C...Prepare removal of participating quarks from ER.
22851                   K(IP,1)=-1
22852                 ENDIF
22853   800         CONTINUE
22854             ENDIF
22855  
22856 C...Update so ER pointers to collapsed quarks
22857 C...now go to collapsed object.
22858             DO 820 I=MINT(84)+1,N
22859               IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22860      &             .K(I,1).GT.0) THEN
22861                 DO 810 ISID=4,5
22862                   IMO=K(I,ISID)/MSTU(5)
22863                   IDA=MOD(K(I,ISID),MSTU(5))
22864                   IF (IMO.GT.0) THEN
22865                     IF (K(IMO,1).EQ.-1) IMO=IJU
22866                   ENDIF
22867                   IF (IDA.GT.0) THEN
22868                     IF (K(IDA,1).EQ.-1) IDA=IJU
22869                   ENDIF
22870                   K(I,ISID)=IDA+MSTU(5)*IMO
22871   810           CONTINUE
22872               ENDIF
22873   820       CONTINUE
22874           ENDIF
22875         ENDIF
22876  
22877 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22878 C...(this only happens for baryons, where we want to force the gluon
22879 C...to sit next to the junction. Mesons handled above.)
22880         IF (NBRTOT(JS).EQ.0) THEN
22881           N=N+1
22882           DO 830 IX=1,5
22883             K(N,IX)=0
22884             P(N,IX)=0D0
22885             V(N,IX)=0D0
22886   830     CONTINUE
22887           IGL=N
22888           K(IGL,1)=3
22889           K(IGL,2)=21
22890           K(IGL,3)=MINT(83)+JS
22891           IF (ITJUNC(JS).NE.0) THEN
22892 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22893             JLEG=PYR(0)*NVSUM(JS)+1
22894             I1=JST(JS,JLEG)
22895             JST(JS,JLEG)=IGL
22896             JCT=MCT(I1,ITJUNC(JS))
22897             MCT(IGL,3-ITJUNC(JS))=JCT
22898             NCT=NCT+1
22899             MCT(IGL,ITJUNC(JS))=NCT
22900             MANTI=ITJUNC(JS)-1
22901           ELSE
22902 C...Meson. Should not happen.
22903             CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22904             IF(NERRPR.LT.5) THEN
22905               WRITE(MSTU(11),*) 'This should not have been possible!'
22906               CALL PYLIST(4)
22907               NERRPR=NERRPR+1
22908             ENDIF
22909             MINT(51)=1
22910             RETURN
22911           ENDIF
22912           I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22913           K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22914           K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22915           K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22916           IF (K(I2,2).NE.88) THEN
22917             K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22918           ELSE
22919             IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22920               K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22921             ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22922               K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22923             ELSE
22924               K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22925             ENDIF
22926           ENDIF
22927         ENDIF
22928   840 CONTINUE
22929  
22930 C...Remove collapsed quarks and junctions from ER and update IMI.
22931       CALL PYEDIT(11)
22932  
22933 C...Also update beam remnant part of IMI.
22934       NMI(1)=MINT(31)
22935       NMI(2)=MINT(31)
22936       DO 850 I=MINT(53)+1,N
22937         IF (K(I,1).LE.0) GOTO 850
22938 C...Restore BR quark/diquark/baryon pointers in IMI.
22939         IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22940           JS=K(I,3)-MINT(83)
22941           NMI(JS)=NMI(JS)+1
22942           IMI(JS,NMI(JS),1)=I
22943           IMI(JS,NMI(JS),2)=0
22944         ENDIF
22945   850 CONTINUE
22946  
22947 C...Restore companion information from collapsed gluons.
22948       DO 870 I=MINT(53)+1,N
22949         IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22950           JS=K(I,3)-MINT(83)
22951           JCD=MOD(K(I,4),MSTU(5))
22952           JAD=MOD(K(I,5),MSTU(5))
22953           DO 860 IM=1,NMI(JS)
22954             IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22955             IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22956   860     CONTINUE
22957           IMI(JS,IMC,2)=IMI(JS,IMA,1)
22958           IMI(JS,IMA,2)=IMI(JS,IMC,1)
22959         ENDIF
22960   870 CONTINUE
22961  
22962 C...Renumber colour lines (since some have disappeared)
22963       JCT=0
22964       JCD=0
22965   880 JCT=JCT+1
22966       MFOUND=0
22967       I=MINT(84)
22968   890 I=I+1
22969       IF (I.EQ.N+1) THEN
22970         IF (MFOUND.EQ.0) JCD=JCD+1
22971       ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22972         MCT(I,1)=JCT-JCD
22973         MFOUND=1
22974       ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22975         MCT(I,2)=JCT-JCD
22976         MFOUND=1
22977       ENDIF
22978       IF (I.LE.N) GOTO 890
22979       IF (JCT.LT.NCT) GOTO 880
22980       NCT=JCT-JCD
22981  
22982 C...Reset hard interaction subsystems to their CM frames.
22983       IF (IBOOST.EQ.1) THEN
22984         DO 900 IM=1,MINT(31)
22985           BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22986           CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22987   900   CONTINUE
22988 C...Zero beam remnant longitudinal momenta and energies
22989         DO 910 I=MINT(53)+1,N
22990           P(I,3)=0D0
22991           P(I,4)=0D0
22992   910   CONTINUE
22993       ELSE
22994         CALL PYERRM(9
22995      &       ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22996 C...Kill event and start another.
22997         MINT(51)=1
22998         RETURN
22999       ENDIF
23000  
23001  9999 RETURN
23002       END
23003 C*********************************************************************
23004  
23005 C...PYCTTR
23006 C...Adapted from PYPREP.
23007 C...Assigns LHA1 colour tags to coloured partons based on
23008 C...K(I,4) and K(I,5) colour connection record.
23009 C...KCS negative signifies that a previous tracing should be continued.
23010 C...(in case the tag to be continued is empty, the routine exits)
23011 C...Starts at I and ends at I or IEND.
23012 C...Special considerations for systems with junctions.
23013 C...Special: if IEND=-1, means trace this parton to its color partner,
23014 C...         then exit. If no partner found, exit with 0. 
23015 
23016       SUBROUTINE PYCTTR(I,KCS,IEND)
23017 C...Double precision and integer declarations.
23018       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23019       INTEGER PYK,PYCHGE,PYCOMP
23020 C...Commonblocks.
23021       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23022       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23023       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23024       COMMON/PYINT1/MINT(400),VINT(400)
23025 C...The common block of colour tags.
23026       COMMON/PYCTAG/NCT,MCT(4000,2)
23027       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
23028       DATA NERRPR/0/
23029       SAVE NERRPR
23030  
23031 C...Skip if parton not existing or does not have KCS
23032       IF (K(I,1).LE.0) GOTO 120
23033       KC=PYCOMP(K(I,2))
23034       IF (KC.EQ.0) GOTO 120
23035       KQ=KCHG(KC,2)
23036       IF (KQ.EQ.0) GOTO 120
23037       IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) 
23038      &    GOTO 120
23039  
23040       IF (KCS.GT.0) THEN
23041         NCT=NCT+1
23042 C...Set colour tag of first parton.
23043         MCT(I,KCS-3)=NCT
23044         NCS=NCT
23045       ELSE
23046         KCS=-KCS
23047         NCS=MCT(I,KCS-3)
23048         IF (NCS.EQ.0) GOTO 120
23049       ENDIF
23050  
23051       IA=I
23052       NSTP=0
23053   100 NSTP=NSTP+1
23054       IF(NSTP.GT.4*N) THEN
23055         CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
23056         GOTO 120
23057       ENDIF
23058  
23059 C...Finished if reached final-state triplet.
23060       IF(K(IA,1).EQ.3) THEN
23061         IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
23062       ENDIF
23063  
23064 C...Also finished if reached junction.
23065       IF(K(IA,1).EQ.42) THEN
23066         GOTO 120
23067       ENDIF
23068  
23069 C...GOTO next parton in colour space.
23070   110 IB=IA
23071 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
23072       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
23073      &     .NE.0) THEN
23074         IA=MOD(K(IB,KCS),MSTU(5))
23075         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
23076         MREV=0
23077       ELSE
23078 C...If KCS mother traced or KCS mother nonexistent, switch colour.
23079         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
23080      &       MSTU(5)).EQ.0) THEN
23081           KCS=9-KCS
23082           NCT=NCT+1
23083           NCS=NCT
23084 C...Assign new colour tag on other side of old parton.
23085           MCT(IB,KCS-3)=NCT
23086         ENDIF
23087 C...Goto (new) KCS mother, set mother traced tag
23088         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
23089         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
23090         MREV=1
23091       ENDIF
23092       IF(IA.LE.0.OR.IA.GT.N) THEN
23093         IF (IEND.EQ.-1) THEN
23094           IEND=0
23095           GOTO 120
23096         ENDIF
23097         CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
23098         IF(NERRPR.LT.5) THEN
23099           write(*,*) 'began at ',I
23100           write(*,*) 'ended going from', IB, ' to', IA, '  KCS=',KCS,
23101      &        '  NCS=',NCS,'  MREV=',MREV
23102           CALL PYLIST(4)
23103           NERRPR=NERRPR+1
23104         ENDIF
23105         MINT(51)=1
23106         RETURN
23107       ENDIF
23108       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
23109      &     MSTU(5)).EQ.IB) THEN
23110         IF(MREV.EQ.1) KCS=9-KCS
23111         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
23112 C...Set KSC mother traced tag for IA
23113         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
23114       ELSE
23115         IF(MREV.EQ.0) KCS=9-KCS
23116         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
23117 C...Set KCS daughter traced tag for IA
23118         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
23119       ENDIF
23120 C...Assign new colour tag
23121       MCT(IA,KCS-3)=NCS
23122 C...Finish if IEND=-1 and found final-state color partner 
23123       IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
23124         IEND=IA
23125         GOTO 120        
23126       ENDIF
23127       IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
23128  
23129   120 RETURN
23130       END
23131  
23132 *********************************************************************
23133  
23134 C...PYMIHG
23135 C...Collapse JCP1 and connecting tags to JCG1.
23136 C...Collapse JCP2 and connecting tags to JCG2.
23137  
23138       SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
23139 C...Double precision and integer declarations.
23140       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23141       IMPLICIT INTEGER(I-N)
23142       INTEGER PYK,PYCHGE,PYCOMP
23143 C...The event record
23144       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23145 C...Parameters
23146       COMMON/PYINT1/MINT(400),VINT(400)
23147       SAVE /PYJETS/,/PYINT1/
23148 C...Local variables
23149       COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
23150       COMMON /PYCTAG/NCT,MCT(4000,2)
23151       SAVE /PYCBLS/,/PYCTAG/
23152  
23153 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
23154 C...in temporary tag collapse array JCCN. Only break up one connection.
23155       MACCPT=1
23156       MCLPS=0
23157       DO 100 ICC=1,NCC
23158         JCCN(ICC,1)=JCCO(ICC,1)
23159         JCCN(ICC,2)=JCCO(ICC,2)
23160 C...If there was a mother, it was previously connected to JCP1.
23161 C...Should be changed to JCP2.
23162         IF (MCLPS.EQ.0) THEN
23163           IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
23164      &         ,JCP2)) THEN
23165             JCCN(ICC,1)=MAX(JCG2,JCP2)
23166             JCCN(ICC,2)=MIN(JCG2,JCP2)
23167             MCLPS=1
23168           ENDIF
23169         ENDIF
23170   100 CONTINUE
23171 C...Also collapse colours on JCP1 side of JCG1
23172       IF (JCP1.NE.0) THEN
23173         JCCN(NCC+1,1)=MAX(JCP1,JCG1)
23174         JCCN(NCC+1,2)=MIN(JCP1,JCG1)
23175       ELSE
23176         JCCN(NCC+1,1)=MAX(JCP2,JCG2)
23177         JCCN(NCC+1,2)=MIN(JCP2,JCG2)
23178       ENDIF
23179  
23180 C...Initialize event record colour tag array MCT array to MCO.
23181        DO 110 I=MINT(84)+1,N
23182         MCT(I,1)=MCO(I,1)
23183         MCT(I,2)=MCO(I,2)
23184   110 CONTINUE
23185  
23186 C...Collapse tags:
23187 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
23188 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
23189 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
23190 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
23191       DO 160 IS=1,4
23192 C...Skip if junction.
23193         IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
23194 C...Define starting point in tag space.
23195 C...JCA = previous tag
23196 C...JCO = present tag
23197 C...JCN = new tag
23198         IF (MOD(IS,2).EQ.1) THEN
23199           JCO=JCP1
23200           JCN=JCG1
23201           JCALL=JCG1
23202         ELSEIF (MOD(IS,2).EQ.0) THEN
23203           JCO=JCP2
23204           JCN=JCG2
23205           JCALL=JCG2
23206         ENDIF
23207         ITRACE=0
23208   120   ITRACE=ITRACE+1
23209         IF (ITRACE.GT.1000) THEN
23210 C...NB: Proper error message should be defined here.
23211           CALL PYERRM(14
23212      &         ,'(PYMIHG:) Inf loop when collapsing colours.')
23213           MINT(57)=MINT(57)+1
23214           MINT(51)=1
23215           RETURN
23216         ENDIF
23217 C...Collapse all JCN tags to JCALL
23218         DO 130 I=MINT(84)+1,N
23219           IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23220           IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23221   130   CONTINUE
23222 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
23223         IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
23224           JCA=JCN
23225           JCN=JCO
23226         ELSE
23227           JCA=JCO
23228           JCO=JCN
23229         ENDIF
23230 C...If possible, step from JCO to new tag JCN not equal to JCA.
23231         DO 140 ICC=1,NCC+1
23232           IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
23233      &         JCCN(ICC,2)
23234           IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
23235      &         JCCN(ICC,1)
23236   140   CONTINUE
23237 C...Iterate if new colour was arrived at, but don't go in circles.
23238         IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
23239 C...Change all JCN tags in MCO to JCALL in MCT.
23240         DO 150 I=MINT(84)+1,N
23241           IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23242           IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23243 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23244           IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23245      &         .NE.0) MACCPT=0
23246   150   CONTINUE
23247   160 CONTINUE
23248  
23249       DO 200 JCL=NCT,1,-1
23250         JCA=0
23251         JCN=JCL
23252   170   JCO=JCN
23253         DO 180 ICC=1,NCC+1
23254           IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
23255      &         =JCCN(ICC,2)
23256           IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
23257      &         =JCCN(ICC,1)
23258   180   CONTINUE
23259 C...Overpaint all JCN with JCL
23260         IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
23261           DO 190 I=MINT(84)+1,N
23262             IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
23263             IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
23264 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23265             IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23266      &           .NE.0) MACCPT=0
23267   190     CONTINUE
23268           JCA=JCO
23269           GOTO 170
23270         ENDIF
23271   200 CONTINUE
23272  
23273       RETURN
23274       END
23275  
23276 C*********************************************************************
23277  
23278 C...PYMIRM
23279 C...Picks primordial kT and shares longitudinal momentum among
23280 C...beam remnants.
23281  
23282       SUBROUTINE PYMIRM
23283  
23284 C...Double precision and integer declarations.
23285       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23286       IMPLICIT INTEGER(I-N)
23287       INTEGER PYK,PYCHGE,PYCOMP
23288 C...The event record
23289       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23290 C...Parameters
23291       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23292       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23293       COMMON/PYINT1/MINT(400),VINT(400)
23294 C...The common block of colour tags.
23295       COMMON/PYCTAG/NCT,MCT(4000,2)
23296 C...The common block of dangling ends
23297       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
23298      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
23299      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
23300       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
23301 C...Local variables
23302       DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
23303 C...W(I,J)|  J=0    |   1   |   2   |
23304 C...  I=0 | Wrem**2 |  W+   |  W-   |
23305 C...    1 | W1**2   |  W1+  |  W1-  |
23306 C...    2 | W2**2   |  W2+  |  W2-  |
23307 C...4-product
23308       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)
23309 C...Tentative parametrization of <kT> as a function of Q.
23310       SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
23311 C      SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
23312 C      SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
23313       GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
23314 C...Lambda kinematic function.
23315       FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
23316  
23317 C...Beginning and end of beam remnant partons
23318       NOUT=MINT(53)
23319       ISUB=MINT(1)
23320  
23321 C...Loopback point if kinematic choices gives impossible configuration.
23322       NTRY=0
23323   100 NTRY=NTRY+1
23324  
23325 C...Assign kT values on each side separately.
23326       DO 180 JS=1,2
23327  
23328 C...First zero all kT on this side. Skip if no kT to generate.
23329         DO 110 IM=1,NMI(JS)
23330           P(IMI(JS,IM,1),1)=0D0
23331           P(IMI(JS,IM,1),2)=0D0
23332   110   CONTINUE
23333         IF(MSTP(91).LE.0) GOTO 180
23334  
23335 C...Now assign kT to each (non-collapsed) parton in IMI.
23336         DO 170 IM=1,NMI(JS)
23337           I=IMI(JS,IM,1)
23338 C...Select kT according to truncated gaussian or 1/kt6 tails.
23339 C...For first interaction, either use rms width = PARP(91) or fitted.
23340           IF (IM.EQ.1) THEN
23341             SIGMA=PARP(91)
23342             IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
23343               Q=SQRT(PT2MI(IM))
23344               SIGMA=SIGPT(Q)
23345             ENDIF
23346           ELSE
23347 C...For subsequent interactions and BR partons use fragmentation width.
23348             SIGMA=PARJ(21)
23349           ENDIF
23350           PHI=PARU(2)*PYR(0)
23351           PT=0D0
23352           IF(NTRY.LE.100) THEN
23353  111        IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
23354               PT=GETPT(Q,SIGMA)
23355               PTX=PT*COS(PHI)
23356               PTY=PT*SIN(PHI)
23357             ELSEIF (MSTP(91).EQ.2) THEN
23358               CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
23359      &          'available, using MSTP(91)=1.')
23360               CALL PYGIVE('MSTP(91)=1')
23361               GOTO 111
23362             ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
23363 C...Use distribution with kt**6 tails, rms width = PARP(91).
23364               EPS=SQRT(3D0/2D0)*SIGMA
23365 C...Generate PTX and PTY separately, each propto 1/KT**6
23366               DO 119 IXY=1,2
23367 C...Decide which interval to try
23368  112            P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
23369                 IF (PYR(0).LT.P12) THEN
23370 C...Use flat approx with accept/reject up to EPS.
23371                   PT=PYR(0)*EPS
23372                   WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
23373                   IF (PYR(0).GT.WT) GOTO 112
23374                 ELSE
23375 C...Above EPS, use 1/kt**6 approx with accept/reject.
23376                   PT=EPS/(PYR(0)**(1D0/5D0))
23377                   WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
23378                   IF (PYR(0).GT.WT) GOTO 112
23379                 ENDIF
23380                 MSIGN=1
23381                 IF (PYR(0).GT.0.5D0) MSIGN=-1
23382                 IF (IXY.EQ.1) PTX=MSIGN*PT
23383                 IF (IXY.EQ.2) PTY=MSIGN*PT
23384  119          CONTINUE
23385             ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
23386               PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23387               PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23388             ENDIF
23389 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
23390             PT=SQRT(PTX**2+PTY**2)
23391             WT=1D0
23392             IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
23393             IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
23394             PTX=PTX*WT
23395             PTY=PTY*WT
23396             PT=SQRT(PTX**2+PTY**2)
23397           ENDIF
23398  
23399           P(I,1)=P(I,1)+PTX
23400           P(I,2)=P(I,2)+PTY
23401  
23402 C...Compensation kicks, with varying degree of local anticorrelations.
23403           MCORR=MSTP(90)
23404           IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
23405             PTCX=-PTX/(NMI(JS)-1)
23406             PTCY=-PTY/(NMI(JS)-1)
23407             IF(ISUB.EQ.95) THEN
23408               PTCX=-PTX/(NMI(JS)-2)
23409               PTCY=-PTY/(NMI(JS)-2)
23410             ENDIF
23411             DO 120 IMC=1,NMI(JS)
23412               IF (IMC.EQ.IM) GOTO 120
23413               IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
23414               P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
23415               P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
23416   120       CONTINUE
23417           ELSEIF (MCORR.GE.1) THEN
23418             DO 140 MSID=4,5
23419               NNXT(MSID-3)=0
23420 C...Count up # of neighbours on either side
23421               IMO=I
23422   130         IMO=K(IMO,MSID)/MSTU(5)
23423               IF (IMO.EQ.0) GOTO 140
23424               NNXT(MSID-3)=NNXT(MSID-3)+1
23425 C...Stop at quarks and junctions
23426               IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
23427   140       CONTINUE
23428 C...How should compensation be shared when unequal numbers on the
23429 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
23430             NSUM=NNXT(1)+NNXT(2)
23431             T1=0
23432             DO 160 MSID=4,5
23433 C...Total momentum to be compensated on this side
23434               IF (NNXT(MSID-3).EQ.0) GOTO 160
23435               PTCX=-(NNXT(MSID-3)*PTX)/NSUM
23436               PTCY=-(NNXT(MSID-3)*PTY)/NSUM
23437 C...RS: compensation supression factor as we go out from parton I.
23438 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
23439 C...since (for now) MSTP(90) provides enough variability.
23440               RS=0.5D0
23441               FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
23442               IMO=I
23443   150         IDA=IMO
23444               IMO=K(IMO,MSID)/MSTU(5)
23445               IF (IMO.EQ.0) GOTO 160
23446               FAC=FAC*RS
23447               IF (K(IMO,2).NE.88) THEN
23448                 P(IMO,1)=P(IMO,1)+FAC*PTCX
23449                 P(IMO,2)=P(IMO,2)+FAC*PTCY
23450                 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
23451 C...If we reach junction, divide out the kT that would have been
23452 C...assigned to the junction on each of its other legs.
23453               ELSE
23454                 L1=MOD(K(IMO,4),MSTU(5))
23455                 L2=K(IMO,5)/MSTU(5)
23456                 L3=MOD(K(IMO,5),MSTU(5))
23457                 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
23458                 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
23459                 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
23460                 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
23461                 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
23462                 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
23463                 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
23464                 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23465               ENDIF
23466  
23467   160       CONTINUE
23468           ENDIF
23469   170   CONTINUE
23470 C...End assignment of kT values to initiators and remnants.
23471   180 CONTINUE
23472  
23473 C...Check kinematics constraints for non-BR partons.
23474       DO 190 IM=1,MINT(31)
23475         SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23476         PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23477         PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23478         PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23479      &        +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23480         IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23481           IF(NTRY.GE.100) THEN
23482 C...Kill this event and start another.
23483             CALL PYERRM(1,
23484      &           '(PYMIRM:) No consistent (x,kT) sets found')
23485             MINT(51)=1
23486             RETURN
23487           ENDIF
23488           GOTO 100
23489         ENDIF
23490   190 CONTINUE
23491  
23492 C...Calculate W+ and W- available for combined remnant system.
23493       W(0,1)=VINT(1)
23494       W(0,2)=VINT(1)
23495       DO 200 IM=1,MINT(31)
23496         PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23497      &       +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23498         ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23499         W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23500         W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23501   200 CONTINUE
23502 C...Also store Wrem**2 = W+ * W-
23503       W(0,0)=W(0,1)*W(0,2)
23504  
23505       IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23506           IF(NTRY.GE.100) THEN
23507 C...Kill this event and start another.
23508             CALL PYERRM(1,
23509      &    '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23510             MINT(51)=1
23511             RETURN
23512           ENDIF
23513           GOTO 100
23514       ENDIF
23515 
23516 C...Assign unscaled x values to partons/hadrons in each of the
23517 C...beam remnants and calculate unscaled W+ and W- from them.
23518       NTRYX=0
23519   210 NTRYX=NTRYX+1
23520       DO 280 JS=1,2
23521         W(JS,1)=0D0
23522         W(JS,2)=0D0
23523         DO 270 IM=MINT(31)+1,NMI(JS)
23524           I=IMI(JS,IM,1)
23525           KF=K(I,2)
23526           KFA=IABS(KF)
23527           ICOMP=IMI(JS,IM,2)
23528  
23529 C...Skip collapsed gluons and junctions. Reset.
23530           IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23531           IF (KFA.EQ.88) GOTO 270
23532           X=0D0
23533           IVALQ(1)=0
23534           IVALQ(2)=0
23535           ICOMQ(1)=0
23536           ICOMQ(2)=0
23537  
23538 C...If gluon then only beam remnant, so takes all.
23539           IF(KFA.EQ.21) THEN
23540             X=1D0
23541 C...If valence quark then use parametrized valence distribution.
23542           ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23543             IVALQ(1)=KF
23544 C...If companion quark then derive from companion x.
23545           ELSEIF(KFA.LE.6) THEN
23546             ICOMQ(1)=ICOMP
23547 C...If valence diquark then use two parametrized valence distributions.
23548           ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23549      &    ICOMP.EQ.0) THEN
23550             IVALQ(1)=ISIGN(KFA/1000,KF)
23551             IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23552 C...If valence+sea diquark then combine valence + companion choices.
23553           ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23554      &    ICOMP.LT.MSTU(5)) THEN
23555             IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23556               IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23557             ELSE
23558               IVALQ(1)=ISIGN(KFA/1000,KF)
23559             ENDIF
23560             ICOMQ(1)=ICOMP
23561 C...Extra code: workaround for diquark made out of two sea
23562 C...quarks, but where not (yet) ICOMP > MSTU(5).
23563             DO 220 IM1=1,MINT(31)
23564               IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23565                 ICOMQ(2)=IMI(JS,IM1,1)
23566                 IVALQ(1)=0
23567               ENDIF
23568   220       CONTINUE
23569 C...If sea diquark then sum of two derived from companion x.
23570           ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23571              ICOMQ(1)=MOD(ICOMP,MSTU(5))
23572              ICOMQ(2)=ICOMP/MSTU(5)
23573 C...If meson or baryon then use fragmentation function.
23574 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23575           ELSE
23576             KFL3=MOD(KFA/10,10)
23577             IF(MOD(KFA/1000,10).EQ.0) THEN
23578               KFL1=MOD(KFA/100,10)
23579             ELSE
23580               KFL1=MOD(KFA,10000)-10*KFL3-1
23581               IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23582      &        MOD(KFA,10).EQ.2) KFL1=KFL1+2
23583             ENDIF
23584             PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23585             CALL PYZDIS(KFL1,KFL3,PR,X)
23586           ENDIF
23587  
23588           DO 260 IQ=1,2
23589 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23590 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23591 C...In other baryons combine u and d from proton appropriately.
23592             IF(IVALQ(IQ).NE.0) THEN
23593               NVAL=0
23594               IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23595               IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23596               IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23597 C...Meson.
23598               IF(KFIVAL(JS,3).EQ.0) THEN
23599                 MDU=0
23600 C...Baryon with three identical quarks: mix u and d forms.
23601               ELSEIF(NVAL.EQ.3) THEN
23602                 MDU=INT(PYR(0)+5D0/3D0)
23603 C...Baryon, one of two identical quarks: u form.
23604               ELSEIF(NVAL.EQ.2) THEN
23605                 MDU=2
23606 C...Baryon with two identical quarks, but not the one picked: d form.
23607               ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23608      &        KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23609                 MDU=1
23610 C...Baryon with three nonidentical quarks: mix u and d forms.
23611               ELSE
23612                 MDU=INT(PYR(0)+5D0/3D0)
23613               ENDIF
23614               XPOW=0.8D0
23615               IF(MDU.EQ.1) XPOW=3.5D0
23616               IF(MDU.EQ.2) XPOW=2D0
23617   230         XX=PYR(0)**2
23618               IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23619               X=X+XX
23620             ENDIF
23621  
23622 C...Calculation of x of companion quark.
23623             IF(ICOMQ(IQ).NE.0) THEN
23624               XCOMP=1D-4
23625               DO 240 IM1=1,MINT(31)
23626                 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23627   240         CONTINUE
23628               NPOW=MAX(0,MIN(4,MSTP(87)))
23629   250         XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23630               CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23631      &        (XCOMP**2+XX**2)/(XCOMP+XX)**2
23632               IF(CORR.LT.PYR(0)) GOTO 250
23633               X=X+XX
23634             ENDIF
23635   260     CONTINUE
23636  
23637 C...Optionally enchance x of composite systems (e.g. diquarks)
23638           IF (KFA.GT.100) X=PARP(79)*X
23639  
23640 C...Store x. Also calculate light cone energies of each system.
23641           XMI(JS,IM)=X
23642           W(JS,JS)=W(JS,JS)+X
23643           W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23644   270   CONTINUE
23645         W(JS,JS)=W(JS,JS)*W(0,JS)
23646         W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23647         W(JS,0)=W(JS,1)*W(JS,2)
23648   280 CONTINUE
23649  
23650 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23651 C...insensitive to global rescalings of the BR x values).
23652       IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23653      &     THEN
23654         GOTO 210
23655       ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23656         GOTO 100
23657       ELSEIF (NTRYX.GT.100) THEN
23658         CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23659         MINT(57)=MINT(57)+1
23660         MINT(51)=1
23661         RETURN
23662       ENDIF
23663  
23664 C...Compute x rescaling factors
23665       COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23666       R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23667       R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23668  
23669       IF (R1.LT.0.OR.R2.LT.0) THEN
23670         CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23671         MINT(57)=MINT(57)+1
23672         MINT(51)=1
23673       ENDIF
23674  
23675 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23676       W(1,1)=W(1,1)*R1
23677       W(1,2)=W(1,2)/R1
23678       W(2,1)=W(2,1)/R2
23679       W(2,2)=W(2,2)*R2
23680  
23681 C...Rescale BR x values.
23682       DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23683         XMI(1,IM)=XMI(1,IM)*R1
23684         XMI(2,IM)=XMI(2,IM)*R2
23685   290 CONTINUE
23686  
23687 C...Now we have a consistent set of x and kT values.
23688 C...First set up the initiators and their daughters correctly.
23689       DO 300 IM=1,MINT(31)
23690         I1=IMI(1,IM,1)
23691         I2=IMI(2,IM,1)
23692         ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23693      &       (P(I1,2)+P(I2,2))**2
23694         PT12=P(I1,1)**2+P(I1,2)**2
23695         PT22=P(I2,1)**2+P(I2,2)**2
23696 C...p_z
23697         P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23698         P(I2,3)=-P(I1,3)
23699 C...Energies (masses should be zero at this stage)
23700         P(I1,4)=SQRT(PT12+P(I1,3)**2)
23701         P(I2,4)=SQRT(PT22+P(I2,3)**2)
23702  
23703 C...Transverse 12 system initiator velocity:
23704         VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23705         VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23706 C...Boost to overall initiator system rest frame
23707         CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23708         CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23709 
23710 C...Compute phi,theta coordinates of I1 and rotate z axis.
23711         PHI=PYANGL(P(I1,1),P(I1,2))
23712         THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23713         IMIN=IMISEP(IM-1)+1
23714 C...(include documentation lines if MI = 1)
23715         IF (IM.EQ.1) IMIN=MINT(83)+5
23716         IMAX=IMISEP(IM)
23717 C...Rotate entire system in phi
23718         CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23719 C...Only rotate 12 system in theta
23720         CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23721         CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23722 
23723 C...Now boost entire system back to LAB
23724         VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23725         CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23726         CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23727 
23728   300 CONTINUE
23729  
23730  
23731 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23732       DO 320 JS=1,2
23733         DO 310 IM=MINT(31)+1,NMI(JS)
23734           I=IMI(JS,IM,1)
23735 C...Skip collapsed gluons and junctions.
23736           IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23737           IF (KFA.EQ.88) GOTO 310
23738           RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23739           P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23740           P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23741           IF (JS.EQ.2) P(I,3)=-P(I,3)
23742   310   CONTINUE
23743   320 CONTINUE
23744  
23745  
23746 C...Documentation lines
23747       DO 340 JS=1,2
23748         IN=MINT(83)+JS+2
23749         IO=IMI(JS,1,1)
23750         K(IN,1)=21
23751         K(IN,2)=K(IO,2)
23752         K(IN,3)=MINT(83)+JS
23753         K(IN,4)=0
23754         K(IN,5)=0
23755         DO 330 J=1,5
23756           P(IN,J)=P(IO,J)
23757           V(IN,J)=V(IO,J)
23758   330   CONTINUE
23759         MCT(IN,1)=MCT(IO,1)
23760         MCT(IN,2)=MCT(IO,2)
23761   340 CONTINUE
23762  
23763 C...Final state colour reconnections.
23764       IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23765  
23766 C...Number of colour tags for which a recoupling will be tried.
23767       NTOT=NCT
23768 C...Number of recouplings to try
23769       MINT(34)=0
23770       NRECP=0
23771       NITER=0
23772   350 NRECP=MINT(34)
23773       NITER=NITER+1
23774       IITER=0
23775   360 IITER=IITER+1
23776       IF (IITER.LE.PARP(78)*NTOT) THEN
23777 C...Select two colour tags at random
23778 C...NB: jj strings do not have colour tags assigned to them,
23779 C...thus they are as yet not affected by anything done here.
23780         JCT=PYR(0)*NCT+1
23781         KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23782         IJ1=0
23783         IJ2=0
23784         IK1=0
23785         IK2=0
23786 C...Find final state partons with this (anti)colour
23787         DO 370 I=MINT(84)+1,N
23788           IF (K(I,1).EQ.3) THEN
23789             IF (MCT(I,1).EQ.JCT) IJ1=I
23790             IF (MCT(I,2).EQ.JCT) IJ2=I
23791             IF (MCT(I,1).EQ.KCT) IK1=I
23792             IF (MCT(I,2).EQ.KCT) IK2=I
23793           ENDIF
23794   370   CONTINUE
23795 C...Only consider recouplings not involving junctions for now.
23796         IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23797  
23798         RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23799         RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23800         IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23801           MCT(IJ2,2)=KCT
23802           MCT(IK2,2)=JCT
23803 C...Count up number of reconnections
23804           MINT(34)=MINT(34)+1
23805         ENDIF
23806         IF (MINT(34).LE.1000) THEN
23807           GOTO 360
23808         ELSE
23809           CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23810           GOTO 380
23811         ENDIF
23812       ENDIF
23813       IF (NRECP.LT.MINT(34)) GOTO 350
23814  
23815 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23816   380 MINT(33)=1
23817  
23818       RETURN
23819       END
23820  
23821 C*********************************************************************
23822  
23823 C...PYFSCR
23824 C...Performs colour annealing.
23825 C...MSTP(95) : CR Type
23826 C...         = 1  : old cut-and-paste reconnections, handled in PYMIHK
23827 C...         = 2  : Type I(no gg loops); hadron-hadron only
23828 C...         = 3  : Type I(no gg loops); all beams
23829 C...         = 4  : Type II(gg loops)  ; hadron-hadron only
23830 C...         = 5  : Type II(gg loops)  ; all beams
23831 C...         = 6  : Type S             ; hadron-hadron only
23832 C...         = 7  : Type S             ; all beams
23833 C...         = 8  : Type P             ; hadron-hadron only
23834 C...         = 9  : Type P             ; all beams
23835 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23836 C...Type S is driven by starting only from free triplets, not octets.
23837 C...Type P is also driven by free triplets, but the reconnect probability
23838 C...is computed from the string density per unit rapidity, where the axis
23839 C...with respect to which the rapidity is computed is the Thrust axis of the
23840 C...event.
23841 C...A string piece remains unchanged with probability
23842 C...    PKEEP = (1-PARP(78))**N
23843 C...This scaling corresponds to each string piece having to go through
23844 C...N other ones, each with probability PARP(78) for reconnection.
23845 C...For types I, II, and S, N is chosen simply as the number of multiple
23846 C...interactions, for a rough scaling with the general level of activity.
23847 C...For type P, N is chosen to be the number of string pieces in a given
23848 C...interval of rapidity (minus one, since the string doesn't reconnect
23849 C...with itself), and the reconnect probability is interpreted as the
23850 C...probability per unit rapidity.
23851 C...It also also possible to apply a dampening factor to the CR strength,
23852 C...using PARP(77), which will cause reconnections among high-pT string
23853 C...pieces to be suppressed.
23854  
23855       SUBROUTINE PYFSCR(IP)
23856 C...Double precision and integer declarations.
23857       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23858       INTEGER PYK,PYCHGE,PYCOMP
23859 C...Commonblocks.
23860       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23861       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23862       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23863       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23864       COMMON/PYINT1/MINT(400),VINT(400)
23865 C...The common block of colour tags.
23866       COMMON/PYCTAG/NCT,MCT(4000,2)
23867       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23868      &/PYPARS/
23869 C...MCN: Temporary storage of new colour tags
23870       INTEGER MCN(4000,2)
23871 C...Arrays for storing color strings
23872       PARAMETER (NBINY=100)
23873       INTEGER ICR(4000),MSCR(4000)
23874       INTEGER IOPT(4000), NSTRY(NBINY)
23875       DOUBLE PRECISION RLOPTC(4000)
23876  
23877 C...Function to give four-product.
23878       FOUR(I,J)=P(I,4)*P(J,4)
23879      &          -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23880  
23881 C...Check valid range of MSTP(95), local copy
23882       IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23883       MSTP95=MOD(MSTP(95),10)
23884 C...Set whether CR allowed inside resonance systems or not
23885 C...(not implemented yet)
23886 C      MRESCR=1
23887 C      IF (MSTP(95).GE.10) MRESCR=0
23888  
23889 C...Check whether colour tags already defined
23890       IF (MINT(33).EQ.0) THEN
23891 C...Erase any existing colour tags for this event
23892         DO 100 I=1,N
23893           MCT(I,1)=0
23894           MCT(I,2)=0
23895   100   CONTINUE
23896 C...Create colour tags for this event
23897         DO 120 I=1,N
23898           IF (K(I,1).EQ.3) THEN
23899             DO 110 KCS=4,5
23900               KCSIN=KCS
23901               IF (MCT(I,KCSIN-3).EQ.0) THEN
23902                 CALL PYCTTR(I,KCSIN,I)
23903               ENDIF
23904   110       CONTINUE
23905           ENDIF
23906   120   CONTINUE
23907 C...Instruct PYPREP to use colour tags
23908         MINT(33)=1
23909       ENDIF
23910  
23911 C...For MSTP(95) even, only apply to hadron-hadron
23912       KA1=IABS(MINT(11))
23913       KA2=IABS(MINT(12))
23914       IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23915  
23916 C...Initialize new tag array (but do not delete old yet)
23917       LCT=NCT
23918       DO 130 I=MAX(1,IP),N
23919          MCN(I,1)=0
23920          MCN(I,2)=0
23921   130 CONTINUE
23922  
23923 C...For Paquis type, determine thrust axis (default along Z axis)
23924       TX=0D0
23925       TY=0D0
23926       TZ=1D0
23927       IF (MSTP95.GE.8) THEN
23928         CALL PYTHRU(THRDUM,OBLDUM)
23929         TX = P(N+1,1)
23930         TY = P(N+1,2)
23931         TZ = P(N+1,3)
23932       ENDIF
23933  
23934 C...For each final-state dipole, check whether string should be
23935 C...preserved.
23936       NCR=0
23937       IA=0
23938       IC=0
23939       RAPMAX=0.0
23940  
23941       ICTMIN=NCT
23942       DO 150 ICT=1,NCT
23943         IA=0
23944         IC=0
23945         DO 140 I=MAX(1,IP),N
23946           IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23947           IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23948   140   CONTINUE
23949         IF (IC.NE.0.AND.IA.NE.0) THEN
23950 C...Save smallest NCT value so far
23951           ICTMIN = MIN(ICTMIN,ICT)
23952 C...For Paquis algorithm, just store all string pieces for now
23953           IF (MSTP95.GE.8) THEN
23954 C...  Add coloured parton
23955             NCR=NCR+1
23956             ICR(NCR)=IC
23957             MSCR(NCR)=1
23958             IOPT(NCR)=0
23959 C...  Store rapidity (along Thrust axis) in RLOPT for the time being
23960 C...  Add pion mass headroom to energy for this calculation
23961             EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
23962             PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
23963             RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23964 C...  Add anti-coloured parton
23965             NCR       = NCR+1
23966             ICR(NCR)  = IA
23967             MSCR(NCR) = 2
23968             IOPT(NCR) = 0
23969 C...  Store rapidity (along Thrust axis) in RLOPT for the time being
23970             EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
23971             PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
23972             RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23973 C...  Keep track of largest endpoint "rapidity"
23974             RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
23975             RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
23976           ELSE
23977             CRMODF=1D0
23978 C...  Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23979 C...  (so far ignores the possibility that the whole "muck" may be moving.)
23980             IF (PARP(77).GT.0D0) THEN
23981               PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23982 C...  For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23983               IF (KA1.LT.100.AND.KA2.LT.100) THEN
23984                 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23985               ELSE
23986                 P2STR = 3D0/2D0 * PT2STR
23987               ENDIF
23988               RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23989               RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23990 C...  Estimate number of particles ~ log(M2), cut off at 1.
23991               RLOGM2=MAX(1D0,LOG(RM2STR))
23992               P2AVG=P2STR/RLOGM2
23993 C...  Supress reconnection probability by 1/(1+P77*P2AVG)
23994               CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23995             ENDIF
23996             PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23997             IF (PYR(0).LE.PKEEP) THEN
23998               LCT=LCT+1
23999               MCN(IC,1)=LCT
24000               MCN(IA,2)=LCT
24001             ELSE
24002 C...  Add coloured parton
24003               NCR=NCR+1
24004               ICR(NCR)=IC
24005               MSCR(NCR)=1
24006               IOPT(NCR)=0
24007               RLOPTC(NCR)=1D19
24008 C...  Add anti-coloured parton
24009               NCR=NCR+1
24010               ICR(NCR)=IA
24011               MSCR(NCR)=2
24012               IOPT(NCR)=0
24013               RLOPTC(NCR)=1D19
24014             ENDIF
24015           ENDIF
24016         ENDIF
24017   150 CONTINUE
24018  
24019 C...PAQUIS TYPE
24020       IF (MSTP95.GE.8) THEN
24021 C...  For Paquis type, make "histogram" of string densities along thrust axis
24022         RAPMIN = -RAPMAX
24023         DRAP   = 2*RAPMAX/(1D0*NBINY)
24024 C...  Explicitly zero histogram bin content
24025         DO 160 IBINY=1,NBINY
24026           NSTRY(IBINY)=0
24027   160   CONTINUE
24028         DO 180 ISTR=1,NCR-1,2
24029           IC = ICR(ISTR)
24030           IA = ICR(ISTR+1)
24031           Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
24032           Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
24033           DO 170 IBINY=1,NBINY
24034             YBINLO = RAPMIN + (IBINY-1)*DRAP
24035 C...  If bin inside string piece, add 1 in this bin
24036 C...  (Strictly speaking: if it starts before midpoint and ends after midpoint)
24037             IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
24038      &           NSTRY(IBINY) = NSTRY(IBINY) + 1
24039   170     CONTINUE
24040   180   CONTINUE
24041 C...  Loop over pieces to find individual reconnect probability
24042         DO 200 IS=1,NCR-1,2
24043           DNSUM  = 0D0
24044           DNAVG  = 0D0
24045 C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
24046           RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24047           RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24048 C...Make sure integer bin numbers lie inside proper range
24049           IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
24050           IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
24051 C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
24052 C...(also smaller than DRAP if a one-unit wide piece is stretched
24053 C... over 2 bins, thus making the computation more accurate)
24054           DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
24055 C...  Decide whether to suppress reconnections in high-pT string pieces
24056           CRMODF = 1D0
24057           IF (PARP(77).GT.0D0) THEN
24058 C...  Total string piece energy, momentum squared, and components
24059             EES  =  P(ICR(IS),4) + P(ICR(IS+1),4)
24060             PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
24061      &           + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
24062      &           + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
24063             PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ
24064      &           + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
24065             PTTS = SQRT(PPS2 - PZTS**2)
24066 C...  Mass of string piece in units of mpi (at least 1)
24067             RMPI2  = 0.135D0
24068             RM2STR = MAX(RMPI2,EES**2 - PPS2)
24069 C...  Estimate number of pions ~ log(M2) (at least 1)
24070             RNPI   = LOG(RM2STR/RMPI2)+1D0
24071             PT2AVG = (PTTS / RNPI)**2
24072 C...  Supress reconnection probability by 1/(1+P77*P2AVG)
24073             CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
24074           ENDIF
24075           PKEEP = 1.0
24076           DO 190 IBINY=IBINLO,IBINHI
24077 C            DNSUM = DNSUM + 1D0
24078             DNOVL = MAX(0,NSTRY(IBINY)-1)
24079             PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
24080 C            DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
24081   190     CONTINUE
24082 C          DNAVG = DNAVG / DNSUM
24083 C...  If keeping string piece, save
24084           IF (PYR(0).LE.PKEEP) THEN
24085             LCT = LCT+1
24086             MCN(ICR(IS),1)=LCT
24087             MCN(ICR(IS+1),2)=LCT
24088           ENDIF
24089   200   CONTINUE
24090       ENDIF
24091  
24092 C...Skip if there is only one possibility
24093       IF (NCR.LE.2) THEN
24094         GOTO 9999
24095       ENDIF
24096  
24097 C...Reorder, so ordered in I (in order to correspond to old algorithm)
24098       NLOOP=0
24099   210 NLOOP=NLOOP+1
24100       MORD=1
24101       DO 220 IC1=1,NCR-1
24102         I1=ICR(IC1)
24103         I2=ICR(IC1+1)
24104         IF (I1.GT.I2) THEN
24105           IT=I1
24106           MST=MSCR(IC1)
24107           ICR(IC1)=I2
24108           MSCR(IC1)=MSCR(IC1+1)
24109           ICR(IC1+1)=IT
24110           MSCR(IC1+1)=MST
24111           MORD=0
24112         ENDIF
24113   220 CONTINUE
24114 C...Max do 1000 reordering loops
24115       IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 210
24116  
24117 C...PS: 03 May 2010
24118 C...For Seattle and Paquis types, check if there is a dangling tag
24119 C...Needed for special case when entire reconnected state was one or
24120 C...more gluon loops in original topology in which case these CR
24121 C...algorithms need to be told they shouldn't look for a dangling tag.
24122       M3FREE=0
24123       IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
24124         DO 230 IC1=1,NCR
24125           I1=ICR(IC1)
24126 C...Color charge
24127           MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
24128           IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
24129           IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
24130           IF (MCI.EQ.2) THEN
24131             IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
24132             IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
24133           ENDIF
24134   230   CONTINUE
24135       ENDIF
24136  
24137 C...Loop over CR partons
24138 C...(Ignore junctions for now.)
24139       NLOOP=0
24140   240 NLOOP=NLOOP+1
24141       RLMAX=0D0
24142       ICRMAX=0
24143 C...Loop over coloured partons
24144       DO 260 IC1=1,NCR
24145 C...Retrieve parton Event Record index and Colour Side
24146         I=ICR(IC1)
24147         MSI=MSCR(IC1)
24148 C...Skip already connected partons
24149         IF (MCN(I,MSI).NE.0) GOTO 260
24150 C...Shorthand for colour charge
24151         MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24152 C...For Seattle algorithm, only start from partons with one dangling
24153 C...colour tag (unless there aren't any, cf. M3FREE above.)
24154         IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
24155           IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0
24156      &         .AND.M3FREE.EQ.1) THEN
24157             GOTO 260
24158           ENDIF
24159         ENDIF
24160 C...Retrieve saved optimal partner
24161         IO=IOPT(IC1)
24162         IF (IO.NE.0) THEN
24163 C...Reject saved optimal partner if latter is now connected
24164 C...(Also reject if using model S1, since saved partner may
24165 C...now give rise to gg loop.)
24166           IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
24167             IOPT(IC1)=0
24168             RLOPTC(IC1)=1D19
24169           ENDIF
24170         ENDIF
24171         RLOPT=RLOPTC(IC1)
24172 C...Search for new optimal partner if necessary
24173         IF (IOPT(IC1).EQ.0) THEN
24174           MBROPT=0
24175           MGGOPT=0
24176           RLOPT=1D19
24177 C...Loop over partons you can connect to
24178           DO 250 IC2=1,NCR
24179             J=ICR(IC2)
24180             MSJ=MSCR(IC2)
24181 C...Skip if already connected
24182             IF (MCN(J,MSJ).NE.0) GOTO 250
24183 C...Skip if this not colour-anticolour pair
24184             IF (MSI.EQ.MSJ) GOTO 250
24185 C...And do not let gluons connect to themselves
24186             IF (I.EQ.J) GOTO 250
24187 C...Suppress direct connections between partons in same Beam Remnant
24188             MBRSTR=0
24189             IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
24190      &          MBRSTR=1
24191 C...Shorthand for colour charge
24192             MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
24193 C...Check for gluon loops
24194             MGGSTR=0
24195             IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
24196               IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
24197      &            MCN(I,2).NE.0) MGGSTR=1
24198             ENDIF
24199 C...Save connection with smallest lambda measure
24200             RL=FOUR(I,J)
24201 C...If best so far was a BR string and this is not, also save.
24202 C...If best so far was a gg string and this is not, also save.
24203 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
24204 C...string with a small Lambda measure as the last step, this connection
24205 C...will be saved regardless of whether other possibilities existed.
24206 C...I.e., there should really be a check whether another possibility has
24207 C...already been found, but since these models are now actively in use
24208 C...and uncertainties are anyway large, the algorithm is left as it is.
24209 C...(correction --> Pythia 8 ?)
24210             IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
24211      &          .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
24212      &          .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
24213 C...Paquis type: fix problem above
24214               MPAQ = 0
24215               IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
24216                 IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
24217                 IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
24218               ENDIF
24219               IF (MPAQ.EQ.0) THEN
24220                 RLOPT=RL
24221                 RLOPTC(IC1)=RLOPT
24222                 IOPT(IC1)=J
24223                 MBROPT=MBRSTR
24224                 MGGOPT=MGGSTR
24225               ENDIF
24226             ENDIF
24227   250     CONTINUE
24228         ENDIF
24229         IF (IOPT(IC1).NE.0) THEN
24230 C...Save pair with largest RLOPT so far
24231           IF (RLOPT.GE.RLMAX) THEN
24232             ICRMAX=IC1
24233             RLMAX=RLOPT
24234           ENDIF
24235         ENDIF
24236   260 CONTINUE
24237 C...Save and iterate
24238       ICMAX=0
24239       IF (ICRMAX.GT.0) THEN
24240         LCT=LCT+1
24241         ILMAX=ICR(ICRMAX)
24242         JLMAX=IOPT(ICRMAX)
24243         ICMAX=MSCR(ICRMAX)
24244         JCMAX=3-ICMAX
24245         MCN(ILMAX,ICMAX)=LCT
24246         MCN(JLMAX,JCMAX)=LCT
24247         IF (NLOOP.LE.2*(N-IP)) THEN
24248           GOTO 240
24249         ELSE
24250           CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
24251           CALL PYSTOP(11)
24252         ENDIF
24253       ELSE
24254 C...Save and exit. First check for leftover gluon(s)
24255         DO 290 I=MAX(1,IP),N
24256 C...Check colour charge
24257           MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24258           IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 290
24259           IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
24260 C...Decide where to put left-over gluon (minimal insertion)
24261             ICMAX=0
24262             RLMAX=1D19
24263 C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
24264             DO 280 KCT=ICTMIN,LCT
24265               IC=0
24266               IA=0
24267               DO 270 IT=MAX(1,IP),N
24268                 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 270
24269                 IF (MCN(IT,1).EQ.KCT) IC=IT
24270                 IF (MCN(IT,2).EQ.KCT) IA=IT
24271   270         CONTINUE
24272 C...Skip if this color tag no longer present in event record
24273               IF (IC.EQ.0.OR.IA.EQ.0) GOTO 280
24274               RL=FOUR(IC,I)*FOUR(IA,I)
24275               IF (RL.LT.RLMAX) THEN
24276                 RLMAX=RL
24277                 ICMAX=IC
24278                 IAMAX=IA
24279               ENDIF
24280   280       CONTINUE
24281             LCT=LCT+1
24282             MCN(I,1)=MCN(ICMAX,1)
24283             MCN(I,2)=LCT
24284             MCN(ICMAX,1)=LCT
24285           ENDIF
24286   290   CONTINUE
24287 C...Here we need to loop over entire event.
24288         DO 300 IZ=MAX(1,IP),N
24289 C...Do not erase parton shower colour history
24290           IF (K(IZ,1).NE.3) GOTO 300
24291 C...Check colour charge
24292           MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
24293           IF (MCI.EQ.0) GOTO 300
24294           IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
24295           IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
24296   300   CONTINUE
24297       ENDIF
24298  
24299  9999 RETURN
24300       END
24301 
24302 C*********************************************************************
24303  
24304 C...PYDIFF
24305 C...Handles diffractive and elastic scattering.
24306  
24307       SUBROUTINE PYDIFF
24308  
24309 C...Double precision and integer declarations.
24310       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24311       IMPLICIT INTEGER(I-N)
24312       INTEGER PYK,PYCHGE,PYCOMP
24313 C...Commonblocks.
24314       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24315       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24316       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24317       COMMON/PYINT1/MINT(400),VINT(400)
24318       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
24319  
24320 C...Reset K, P and V vectors. Store incoming particles.
24321       DO 110 JT=1,MSTP(126)+10
24322         I=MINT(83)+JT
24323         DO 100 J=1,5
24324           K(I,J)=0
24325           P(I,J)=0D0
24326           V(I,J)=0D0
24327   100   CONTINUE
24328   110 CONTINUE
24329       N=MINT(84)
24330       MINT(3)=0
24331       MINT(21)=0
24332       MINT(22)=0
24333       MINT(23)=0
24334       MINT(24)=0
24335       MINT(4)=4
24336       DO 130 JT=1,2
24337         I=MINT(83)+JT
24338         K(I,1)=21
24339         K(I,2)=MINT(10+JT)
24340         DO 120 J=1,5
24341           P(I,J)=VINT(285+5*JT+J)
24342   120   CONTINUE
24343   130 CONTINUE
24344       MINT(6)=2
24345  
24346 C...Subprocess; kinematics.
24347       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
24348       PZ=SQRT(SQLAM)/(2D0*VINT(1))
24349       DO 200 JT=1,2
24350         I=MINT(83)+JT
24351         PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
24352         KFH=MINT(102+JT)
24353  
24354 C...Elastically scattered particle. (Except elastic GVMD states.)
24355         IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
24356      &  MINT(106+JT).NE.3)) THEN
24357           N=N+1
24358           K(N,1)=1
24359           K(N,2)=KFH
24360           K(N,3)=I+2
24361           P(N,3)=PZ*(-1)**(JT+1)
24362           P(N,4)=PE
24363           P(N,5)=SQRT(VINT(62+JT))
24364  
24365 C...Decay rho from elastic scattering of gamma with sin**2(theta)
24366 C...distribution of decay products (in rho rest frame).
24367           IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
24368             NSAV=N
24369             DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
24370             P(N,3)=0D0
24371             P(N,4)=P(N,5)
24372             CALL PYDECY(NSAV)
24373             IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
24374               PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
24375               CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
24376               THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
24377               CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
24378   140         CTHE=2D0*PYR(0)-1D0
24379               IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
24380               CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
24381             ENDIF
24382             CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
24383           ENDIF
24384  
24385 C...Diffracted particle: low-mass system to two particles.
24386         ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
24387           N=N+2
24388           K(N-1,1)=1
24389           K(N,1)=1
24390           K(N-1,3)=I+2
24391           K(N,3)=I+2
24392           PMMAS=SQRT(VINT(62+JT))
24393           NTRY=0
24394   150     NTRY=NTRY+1
24395           IF(NTRY.LT.20) THEN
24396             MINT(105)=MINT(102+JT)
24397             MINT(109)=MINT(106+JT)
24398             CALL PYSPLI(KFH,21,KFL1,KFL2)
24399             CALL PYKFDI(KFL1,0,KFL3,KF1)
24400             IF(KF1.EQ.0) GOTO 150
24401             CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
24402             IF(KF2.EQ.0) GOTO 150
24403           ELSE
24404             KF1=KFH
24405             KF2=111
24406           ENDIF
24407           PM1=PYMASS(KF1)
24408           PM2=PYMASS(KF2)
24409           IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
24410           K(N-1,2)=KF1
24411           K(N,2)=KF2
24412           P(N-1,5)=PM1
24413           P(N,5)=PM2
24414           PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
24415      &    4D0*PM1**2*PM2**2))/(2D0*PMMAS)
24416           P(N-1,3)=PZP
24417           P(N,3)=-PZP
24418           P(N-1,4)=SQRT(PM1**2+PZP**2)
24419           P(N,4)=SQRT(PM2**2+PZP**2)
24420           CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
24421      &    0D0,0D0,0D0)
24422           DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
24423           CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
24424  
24425 C...Diffracted particle: valence quark kicked out.
24426         ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
24427      &    PARP(101))) THEN
24428           N=N+2
24429           K(N-1,1)=2
24430           K(N,1)=1
24431           K(N-1,3)=I+2
24432           K(N,3)=I+2
24433           MINT(105)=MINT(102+JT)
24434           MINT(109)=MINT(106+JT)
24435           CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
24436           P(N-1,5)=PYMASS(K(N-1,2))
24437           P(N,5)=PYMASS(K(N,2))
24438           SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
24439      &    4D0*P(N-1,5)**2*P(N,5)**2
24440           P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
24441      &    P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
24442           P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
24443           P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
24444           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24445  
24446 C...Diffracted particle: gluon kicked out.
24447         ELSE
24448           N=N+3
24449           K(N-2,1)=2
24450           K(N-1,1)=2
24451           K(N,1)=1
24452           K(N-2,3)=I+2
24453           K(N-1,3)=I+2
24454           K(N,3)=I+2
24455           MINT(105)=MINT(102+JT)
24456           MINT(109)=MINT(106+JT)
24457           CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
24458           K(N-1,2)=21
24459           P(N-2,5)=PYMASS(K(N-2,2))
24460           P(N-1,5)=0D0
24461           P(N,5)=PYMASS(K(N,2))
24462 C...Energy distribution for particle into two jets.
24463   160     IMB=1
24464           IF(MOD(KFH/1000,10).NE.0) IMB=2
24465           CHIK=PARP(92+2*IMB)
24466           IF(MSTP(92).LE.1) THEN
24467             IF(IMB.EQ.1) CHI=PYR(0)
24468             IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24469           ELSEIF(MSTP(92).EQ.2) THEN
24470             CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
24471           ELSEIF(MSTP(92).EQ.3) THEN
24472             CUT=2D0*0.3D0/VINT(1)
24473   170       CHI=PYR(0)**2
24474             IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
24475      &      PYR(0)) GOTO 170
24476           ELSEIF(MSTP(92).EQ.4) THEN
24477             CUT=2D0*0.3D0/VINT(1)
24478             CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
24479   180       CHIR=CUT*CUTR**PYR(0)
24480             CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
24481             IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
24482           ELSE
24483             CUT=2D0*0.3D0/VINT(1)
24484             CUTA=CUT**(1D0-PARP(98))
24485             CUTB=(1D0+CUT)**(1D0-PARP(98))
24486   190       CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
24487             IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
24488      &      (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
24489           ENDIF
24490           IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
24491      &    VINT(62+JT)) GOTO 160
24492           SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
24493           PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
24494      &    (2D0*VINT(62+JT))
24495           PEI=SQRT(PZI**2+SQM)
24496           PQQP=(1D0-CHI)*(PEI+PZI)
24497           P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
24498           P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
24499           P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
24500           P(N-1,3)=P(N-1,4)*(-1)**JT
24501           P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
24502           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24503         ENDIF
24504  
24505 C...Documentation lines.
24506         K(I+2,1)=21
24507         IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
24508         IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
24509      &  MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
24510         K(I+2,3)=I
24511         P(I+2,3)=PZ*(-1)**(JT+1)
24512         P(I+2,4)=PE
24513         P(I+2,5)=SQRT(VINT(62+JT))
24514   200 CONTINUE
24515  
24516 C...Rotate outgoing partons/particles using cos(theta).
24517       IF(VINT(23).LT.0.9D0) THEN
24518         CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
24519       ELSE
24520         CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
24521       ENDIF
24522  
24523       RETURN
24524       END
24525  
24526 C*********************************************************************
24527  
24528 C...PYDISG
24529 C...Set up a DIS process as gamma* + f -> f, with beam remnant
24530 C...and showering added consecutively. Photon flux by the PYGAGA
24531 C...routine (if at all).
24532  
24533       SUBROUTINE PYDISG
24534  
24535 C...Double precision and integer declarations.
24536       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24537       IMPLICIT INTEGER(I-N)
24538       INTEGER PYK,PYCHGE,PYCOMP
24539 C...Parameter statement to help give large particle numbers.
24540       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24541      &KEXCIT=4000000,KDIMEN=5000000)
24542 C...Commonblocks.
24543       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24544       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24545       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24546       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24547       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24548       COMMON/PYINT1/MINT(400),VINT(400)
24549       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
24550 C...Local arrays.
24551       DIMENSION PMS(4)
24552  
24553 C...Choice of subprocess, number of documentation lines
24554       IDOC=7
24555       MINT(3)=IDOC-6
24556       MINT(4)=IDOC
24557       IPU1=MINT(84)+1
24558       IPU2=MINT(84)+2
24559       IPU3=MINT(84)+3
24560       ISIDE=1
24561       IF(MINT(107).EQ.4) ISIDE=2
24562  
24563 C...Reset K, P and V vectors. Store incoming particles
24564       DO 110 JT=1,MSTP(126)+20
24565         I=MINT(83)+JT
24566         DO 100 J=1,5
24567           K(I,J)=0
24568           P(I,J)=0D0
24569           V(I,J)=0D0
24570   100   CONTINUE
24571   110 CONTINUE
24572       DO 130 JT=1,2
24573         I=MINT(83)+JT
24574         K(I,1)=21
24575         K(I,2)=MINT(10+JT)
24576         DO 120 J=1,5
24577           P(I,J)=VINT(285+5*JT+J)
24578   120   CONTINUE
24579   130 CONTINUE
24580       MINT(6)=2
24581  
24582 C...Store incoming partons in hadronic CM-frame
24583       DO 140 JT=1,2
24584         I=MINT(84)+JT
24585         K(I,1)=14
24586         K(I,2)=MINT(14+JT)
24587         K(I,3)=MINT(83)+2+JT
24588   140 CONTINUE
24589       IF(MINT(15).EQ.22) THEN
24590         P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
24591         P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
24592         P(MINT(84)+1,5)=-SQRT(VINT(307))
24593         P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
24594         P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
24595         KFRES=MINT(16)
24596         ISIDE=2
24597       ELSE
24598         P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
24599         P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
24600         P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
24601         P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
24602         P(MINT(84)+1,5)=-SQRT(VINT(308))
24603         KFRES=MINT(15)
24604         ISIDE=1
24605       ENDIF
24606       SIDESG=(-1D0)**(ISIDE-1)
24607  
24608 C...Copy incoming partons to documentation lines.
24609       DO 170 JT=1,2
24610         I1=MINT(83)+4+JT
24611         I2=MINT(84)+JT
24612         K(I1,1)=21
24613         K(I1,2)=K(I2,2)
24614         K(I1,3)=I1-2
24615         DO 150 J=1,5
24616           P(I1,J)=P(I2,J)
24617   150   CONTINUE
24618  
24619 C...Second copy for partons before ISR shower, since no such.
24620         I1=MINT(83)+2+JT
24621         K(I1,1)=21
24622         K(I1,2)=K(I2,2)
24623         K(I1,3)=I1-2
24624         DO 160 J=1,5
24625           P(I1,J)=P(I2,J)
24626   160   CONTINUE
24627   170 CONTINUE
24628  
24629 C...Define initial partons.
24630       NTRY=0
24631   180 NTRY=NTRY+1
24632       IF(NTRY.GT.100) THEN
24633         MINT(51)=1
24634         RETURN
24635       ENDIF
24636  
24637 C...Scattered quark in hadronic CM frame.
24638       I=MINT(83)+7
24639       K(IPU3,1)=3
24640       K(IPU3,2)=KFRES
24641       K(IPU3,3)=I
24642       P(IPU3,5)=PYMASS(KFRES)
24643       P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24644       P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24645       P(IPU3,5)=0D0
24646       K(I,1)=21
24647       K(I,2)=KFRES
24648       K(I,3)=MINT(83)+4+ISIDE
24649       P(I,3)=P(IPU3,3)
24650       P(I,4)=P(IPU3,4)
24651       P(I,5)=P(IPU3,5)
24652       N=IPU3
24653       MINT(21)=KFRES
24654       MINT(22)=0
24655  
24656 C...No primordial kT, or chosen according to truncated Gaussian or
24657 C...exponential, or (for photon) predetermined or power law.
24658   190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24659         IF(MSTP(91).LE.0) THEN
24660           PT=0D0
24661         ELSEIF(MSTP(91).EQ.1) THEN
24662           PT=PARP(91)*SQRT(-LOG(PYR(0)))
24663         ELSE
24664           RPT1=PYR(0)
24665           RPT2=PYR(0)
24666           PT=-PARP(92)*LOG(RPT1*RPT2)
24667         ENDIF
24668         IF(PT.GT.PARP(93)) GOTO 190
24669       ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24670         PTA=SQRT(VINT(282+ISIDE))
24671         PTB=0D0
24672         IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24673           PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24674         ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24675           RPT1=PYR(0)
24676           RPT2=PYR(0)
24677           PTB=-PARP(99)*LOG(RPT1*RPT2)
24678         ENDIF
24679         IF(PTB.GT.PARP(100)) GOTO 190
24680         PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24681         IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24682       ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24683         IF(MSTP(93).LE.0) THEN
24684           PT=0D0
24685         ELSEIF(MSTP(93).EQ.1) THEN
24686           PT=PARP(99)*SQRT(-LOG(PYR(0)))
24687         ELSEIF(MSTP(93).EQ.2) THEN
24688           RPT1=PYR(0)
24689           RPT2=PYR(0)
24690           PT=-PARP(99)*LOG(RPT1*RPT2)
24691         ELSEIF(MSTP(93).EQ.3) THEN
24692           HA=PARP(99)**2
24693           HB=PARP(100)**2
24694           PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24695         ELSE
24696           HA=PARP(99)**2
24697           HB=PARP(100)**2
24698           IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24699           PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24700         ENDIF
24701         IF(PT.GT.PARP(100)) GOTO 190
24702       ELSE
24703         PT=0D0
24704       ENDIF
24705       VINT(156+ISIDE)=PT
24706       PHI=PARU(2)*PYR(0)
24707       P(IPU3,1)=PT*COS(PHI)
24708       P(IPU3,2)=PT*SIN(PHI)
24709       P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24710       PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24711       PCP=P(IPU3,4)+ABS(P(IPU3,3))
24712  
24713 C...Find one or two beam remnants.
24714       MINT(105)=MINT(102+ISIDE)
24715       MINT(109)=MINT(106+ISIDE)
24716       CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24717       IF(MINT(51).NE.0) THEN
24718         MINT(51)=0
24719         GOTO 180
24720       ENDIF
24721  
24722 C...Store first remnant parton, with colour info and kinematics.
24723       I=N+1
24724       K(I,1)=1
24725       K(I,2)=KFLSP
24726       K(I,3)=MINT(83)+ISIDE
24727       P(I,5)=PYMASS(K(I,2))
24728       KCOL=KCHG(PYCOMP(KFLSP),2)
24729       IF(KCOL.NE.0) THEN
24730         K(I,1)=3
24731         KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24732         K(I,KFLS+3)=MSTU(5)*IPU3
24733         K(IPU3,6-KFLS)=MSTU(5)*I
24734         ICOLR=I
24735       ENDIF
24736       IF(KFLCH.EQ.0) THEN
24737         P(I,1)=-P(IPU3,1)
24738         P(I,2)=-P(IPU3,2)
24739         PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24740         P(I,3)=-P(IPU3,3)
24741         P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24742         PRP=P(I,4)+ABS(P(I,3))
24743  
24744 C...When extra remnant parton or hadron: store extra remnant.
24745       ELSE
24746         I=I+1
24747         K(I,1)=1
24748         K(I,2)=KFLCH
24749         K(I,3)=MINT(83)+ISIDE
24750         P(I,5)=PYMASS(K(I,2))
24751         KCOL=KCHG(PYCOMP(KFLCH),2)
24752         IF(KCOL.NE.0) THEN
24753           K(I,1)=3
24754           KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24755           K(I,KFLS+3)=MSTU(5)*IPU3
24756           K(IPU3,6-KFLS)=MSTU(5)*I
24757           ICOLR=I
24758         ENDIF
24759  
24760 C...Relative transverse momentum when two remnants.
24761         LOOP=0
24762   200   LOOP=LOOP+1
24763         CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24764         P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24765         P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24766         PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24767         P(I,1)=-P(IPU3,1)-P(I-1,1)
24768         P(I,2)=-P(IPU3,2)-P(I-1,2)
24769         PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24770  
24771 C...Relative distribution of energy for particle into jet plus particle.
24772         IMB=1
24773         IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24774         IF(MSTP(94).LE.1) THEN
24775           IF(IMB.EQ.1) CHI=PYR(0)
24776           IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24777           IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24778         ELSEIF(MSTP(94).EQ.2) THEN
24779           CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24780           IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24781         ELSEIF(MSTP(94).EQ.3) THEN
24782           CALL PYZDIS(1,0,PMS(4),ZZ)
24783           CHI=ZZ
24784         ELSE
24785           CALL PYZDIS(1000,0,PMS(4),ZZ)
24786           CHI=ZZ
24787         ENDIF
24788  
24789 C...Construct total transverse mass; reject if too large.
24790         CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24791         PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24792         IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24793           IF(LOOP.LT.10) GOTO 200
24794           GOTO 180
24795         ENDIF
24796         VINT(158+ISIDE)=CHI
24797  
24798 C...Subdivide longitudinal momentum according to value selected above.
24799         PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24800         PW1=(1D0-CHI)*PRP
24801         P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24802         P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24803         PW2=CHI*PRP
24804         P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24805         P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24806       ENDIF
24807       N=I
24808  
24809 C...Boost current and remnant systems to correct frame.
24810       IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24811       DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24812       DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24813      &(2D0*VINT(1)*PCP)
24814       DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24815      &(2D0*VINT(1)*PRP)
24816       DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24817       DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24818       CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24819       CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24820  
24821 C...Let current quark shower; recoil but no showering by colour partner.
24822       QMAX=2D0*SQRT(VINT(309-ISIDE))
24823       MSTJ48=MSTJ(48)
24824       MSTJ(48)=1
24825       PARJ86=PARJ(86)
24826       PARJ(86)=0D0
24827       IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24828       MSTJ(48)=MSTJ48
24829       PARJ(86)=PARJ86
24830  
24831       RETURN
24832       END
24833  
24834 C*********************************************************************
24835  
24836 C...PYDOCU
24837 C...Handles the documentation of the process in MSTI and PARI,
24838 C...and also computes cross-sections based on accumulated statistics.
24839  
24840       SUBROUTINE PYDOCU
24841  
24842 C...Double precision and integer declarations.
24843       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24844       IMPLICIT INTEGER(I-N)
24845       INTEGER PYK,PYCHGE,PYCOMP
24846 C...Commonblocks.
24847       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24848       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24849       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24850       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24851       COMMON/PYINT1/MINT(400),VINT(400)
24852       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24853       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24854       SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24855      &/PYINT5/
24856  
24857 C...Calculate Monte Carlo estimates of cross-sections.
24858       ISUB=MINT(1)
24859       IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24860       NGEN(0,3)=NGEN(0,3)+1
24861       XSEC(0,3)=0D0
24862       DO 100 I=1,500
24863         IF(I.EQ.96.OR.I.EQ.97) THEN
24864           XSEC(I,3)=0D0
24865         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24866      &    I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24867           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24868      &    DBLE(NGEN(96,2)))
24869         ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24870           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24871      &    DBLE(NGEN(96,2)))
24872         ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24873           XSEC(I,3)=0D0
24874         ELSEIF(NGEN(I,2).EQ.0) THEN
24875           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24876      &    DBLE(NGEN(0,2)))
24877         ELSE
24878           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24879      &    DBLE(NGEN(I,2)))
24880         ENDIF
24881         XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24882   100 CONTINUE
24883  
24884 C...Rescale to known low-pT cross-section for standard QCD processes.
24885       IF(MSUB(95).EQ.1) THEN
24886         XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24887      &  XSEC(68,3)+XSEC(95,3)
24888         XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24889         IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24890           FAC=XSECW/XSECH
24891           XSEC(11,3)=FAC*XSEC(11,3)
24892           XSEC(12,3)=FAC*XSEC(12,3)
24893           XSEC(13,3)=FAC*XSEC(13,3)
24894           XSEC(28,3)=FAC*XSEC(28,3)
24895           XSEC(53,3)=FAC*XSEC(53,3)
24896           XSEC(68,3)=FAC*XSEC(68,3)
24897           XSEC(95,3)=FAC*XSEC(95,3)
24898           XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24899         ENDIF
24900       ENDIF
24901  
24902 C...Save information for gamma-p and gamma-gamma.
24903       IF(MINT(121).GT.1) THEN
24904         IGA=MINT(122)
24905         CALL PYSAVE(2,IGA)
24906         CALL PYSAVE(5,0)
24907       ENDIF
24908  
24909 C...Reset information on hard interaction.
24910       DO 110 J=1,200
24911         MSTI(J)=0
24912         PARI(J)=0D0
24913   110 CONTINUE
24914  
24915 C...Copy integer valued information from MINT into MSTI.
24916       DO 120 J=1,32
24917         MSTI(J)=MINT(J)
24918   120 CONTINUE
24919       IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24920  
24921 C...Store cross-section variables in PARI.
24922       PARI(1)=XSEC(0,3)
24923       PARI(2)=XSEC(0,3)/MINT(5)
24924       PARI(7)=VINT(97)
24925       PARI(9)=VINT(99)
24926       PARI(10)=VINT(100)
24927       VINT(98)=VINT(98)+VINT(100)
24928       IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24929  
24930 C...Store kinematics variables in PARI.
24931       PARI(11)=VINT(1)
24932       PARI(12)=VINT(2)
24933       IF(ISUB.NE.95) THEN
24934         DO 130 J=13,26
24935           PARI(J)=VINT(30+J)
24936   130   CONTINUE
24937         PARI(29)=VINT(39)
24938         PARI(30)=VINT(40)
24939         PARI(31)=VINT(141)
24940         PARI(32)=VINT(142)
24941         PARI(33)=VINT(41)
24942         PARI(34)=VINT(42)
24943         PARI(35)=PARI(33)-PARI(34)
24944         PARI(36)=VINT(21)
24945         PARI(37)=VINT(22)
24946         PARI(38)=VINT(26)
24947         PARI(39)=VINT(157)
24948         PARI(40)=VINT(158)
24949         PARI(41)=VINT(23)
24950         PARI(42)=2D0*VINT(47)/VINT(1)
24951       ENDIF
24952  
24953 C...Store information on scattered partons in PARI.
24954       IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24955         DO 140 IS=7,8
24956           I=MINT(IS)
24957           PARI(36+IS)=P(I,3)/VINT(1)
24958           PARI(38+IS)=P(I,4)/VINT(1)
24959           PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24960           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24961      &    SQRT(PR),1D20)),P(I,3))
24962           PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24963           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24964      &    SQRT(PR),1D20)),P(I,3))
24965           PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24966           PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24967           PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24968   140   CONTINUE
24969       ENDIF
24970  
24971 C...Store sum up transverse and longitudinal momenta.
24972       PARI(65)=2D0*PARI(17)
24973       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24974         DO 150 I=MSTP(126)+1,N
24975           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24976           PT=SQRT(P(I,1)**2+P(I,2)**2)
24977           PARI(69)=PARI(69)+PT
24978           IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24979           IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24980   150   CONTINUE
24981         PARI(67)=PARI(68)
24982         PARI(71)=VINT(151)
24983         PARI(72)=VINT(152)
24984         PARI(73)=VINT(151)
24985         PARI(74)=VINT(152)
24986       ELSE
24987         PARI(66)=PARI(65)
24988         PARI(69)=PARI(65)
24989       ENDIF
24990  
24991 C...Store various other pieces of information into PARI.
24992       PARI(61)=VINT(148)
24993       PARI(75)=VINT(155)
24994       PARI(76)=VINT(156)
24995       PARI(77)=VINT(159)
24996       PARI(78)=VINT(160)
24997       PARI(81)=VINT(138)
24998  
24999 C...Store information on lepton -> lepton + gamma in PYGAGA.
25000       MSTI(71)=MINT(141)
25001       MSTI(72)=MINT(142)
25002       PARI(101)=VINT(301)
25003       PARI(102)=VINT(302)
25004       DO 160 I=103,114
25005         PARI(I)=VINT(I+202)
25006   160 CONTINUE
25007  
25008 C...Set information for PYTABU.
25009       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
25010         MSTU(161)=MINT(21)
25011         MSTU(162)=0
25012       ELSEIF(ISET(ISUB).EQ.5) THEN
25013         MSTU(161)=MINT(23)
25014         MSTU(162)=0
25015       ELSE
25016         MSTU(161)=MINT(21)
25017         MSTU(162)=MINT(22)
25018       ENDIF
25019  
25020       RETURN
25021       END
25022  
25023 C*********************************************************************
25024  
25025 C...PYFRAM
25026 C...Performs transformations between different coordinate frames.
25027  
25028       SUBROUTINE PYFRAM(IFRAME)
25029  
25030 C...Double precision and integer declarations.
25031       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25032       IMPLICIT INTEGER(I-N)
25033       INTEGER PYK,PYCHGE,PYCOMP
25034 C...Commonblocks.
25035       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25036       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25037       COMMON/PYINT1/MINT(400),VINT(400)
25038       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25039  
25040 C...Check that transformation can and should be done.
25041       IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
25042      &MINT(91).EQ.1)) THEN
25043         IF(IFRAME.EQ.MINT(6)) RETURN
25044       ELSE
25045         WRITE(MSTU(11),5000) IFRAME,MINT(6)
25046         RETURN
25047       ENDIF
25048  
25049       IF(MINT(6).EQ.1) THEN
25050 C...Transform from fixed target or user specified frame to
25051 C...overall CM frame.
25052         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
25053         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
25054         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
25055       ELSEIF(MINT(6).EQ.3) THEN
25056 C...Transform from hadronic CM frame in DIS to overall CM frame.
25057         CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
25058      &  -VINT(225))
25059       ENDIF
25060  
25061       IF(IFRAME.EQ.1) THEN
25062 C...Transform from overall CM frame to fixed target or user specified
25063 C...frame.
25064         CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
25065       ELSEIF(IFRAME.EQ.3) THEN
25066 C...Transform from overall CM frame to hadronic CM frame in DIS.
25067         CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
25068         CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
25069         CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
25070       ENDIF
25071  
25072 C...Set information about new frame.
25073       MINT(6)=IFRAME
25074       MSTI(6)=IFRAME
25075  
25076  5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
25077      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
25078      &1X,I5)
25079  
25080       RETURN
25081       END
25082  
25083 C*********************************************************************
25084  
25085 C...PYWIDT
25086 C...Calculates full and partial widths of resonances.
25087  
25088       SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
25089  
25090 C...Double precision and integer declarations.
25091       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25092       IMPLICIT INTEGER(I-N)
25093       INTEGER PYK,PYCHGE,PYCOMP
25094 C...Parameter statement to help give large particle numbers.
25095       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25096      &KEXCIT=4000000,KDIMEN=5000000)
25097 C...Commonblocks.
25098       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25099       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25100       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25101       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25102       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25103       COMMON/PYINT1/MINT(400),VINT(400)
25104       COMMON/PYINT4/MWID(500),WIDS(500,5)
25105       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25106       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25107      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
25108       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25109       COMMON/PYPUED/IUED(0:99),RUED(0:99)
25110       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25111      &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
25112 C...Local arrays and saved variables.
25113       COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
25114       DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
25115      &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
25116 C...UED: equivalences between ordered particles (451->475)
25117 C...and UED particle code (5 000 000 + id)
25118       PARAMETER(KKFLMI=451,KKFLMA=475)
25119       DIMENSION CHIDEL(3), IUEDPR(25)
25120       DIMENSION IUEDEQ(KKFLMA),MUED(2)
25121       COMMON/SW1/SW21,CW21
25122       DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
25123      & 6100001,6100002,6100003,6100004,6100005,6100006, 
25124      & 5100001,5100002,5100003,5100004,5100005,5100006, 
25125      & 6100011,6100013,6100015,                         
25126      & 5100012,5100011,5100014,5100013,5100016,5100015, 
25127      & 5100021,5100022,5100023,5100024/                 
25128 C...Save local variables
25129       SAVE MOFSV,WIDWSV,WID2SV
25130 C...Initial values
25131       DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
25132       DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
25133       DATA IUEDPR/25*0/
25134 C...UED: inline functions used in kk width calculus
25135       FKAC1(X,Y)=1.-X**2/Y**2
25136       FKAC2(X,Y)=2.+X**2/Y**2
25137  
25138 C...Compressed code and sign; mass.
25139       KFLA=IABS(KFLR)
25140       KFLS=ISIGN(1,KFLR)
25141       KC=PYCOMP(KFLA)
25142       SHR=SQRT(SH)
25143       PMR=PMAS(KC,1)
25144  
25145 C...Reset width information.
25146       DO 110 I=0,MDCY(KC,3)
25147         WDTP(I)=0D0
25148         DO 100 J=0,5
25149           WDTE(I,J)=0D0
25150   100   CONTINUE
25151   110 CONTINUE
25152 
25153 C...Allow for fudge factor to rescale resonance width.
25154       FUDGE=1D0
25155       IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
25156      &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
25157         IF(MSTP(110).EQ.KFLA) THEN
25158           FUDGE=PARP(110)
25159         ELSEIF(MSTP(110).EQ.-1) THEN
25160           IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
25161         ELSEIF(MSTP(110).EQ.-2) THEN
25162           FUDGE=PARP(110)
25163         ENDIF
25164       ENDIF
25165  
25166 C...Not to be treated as a resonance: return.
25167       IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
25168      &KFLA.NE.22) THEN
25169         WDTP(0)=1D0
25170         WDTE(0,0)=1D0
25171         MINT(61)=0
25172         MINT(62)=0
25173         MINT(63)=0
25174         RETURN
25175  
25176 C...Treatment as a resonance based on tabulated branching ratios.
25177       ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
25178 C...Loop over possible decay channels; skip irrelevant ones.
25179         DO 120 I=1,MDCY(KC,3)
25180           IDC=I+MDCY(KC,2)-1
25181           IF(MDME(IDC,1).LT.0) GOTO 120
25182  
25183 C...Read out decay products and nominal masses.
25184           KFD1=KFDP(IDC,1)
25185           KFC1=PYCOMP(KFD1)
25186 C...Skip dummy modes or unrecognized particles
25187           IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
25188           IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
25189           PM1=PMAS(KFC1,1)
25190           KFD2=KFDP(IDC,2)
25191           KFC2=PYCOMP(KFD2)
25192           IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
25193           PM2=PMAS(KFC2,1)
25194           KFD3=KFDP(IDC,3)
25195           PM3=0D0
25196           IF(KFD3.NE.0) THEN
25197             KFC3=PYCOMP(KFD3)
25198             IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
25199             PM3=PMAS(KFC3,1)
25200           ENDIF
25201  
25202 C...Naive partial width and alternative threshold factors.
25203           WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
25204           IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
25205      &    PM1+PM2+PM3.GE.SHR) THEN
25206              WDTP(I)=0D0
25207           ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
25208             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
25209      &      4D0*PM1**2*PM2**2))/SH
25210           ELSEIF(MDME(IDC,2).EQ.52) THEN
25211             PMA=MAX(PM1,PM2,PM3)
25212             PMC=MIN(PM1,PM2,PM3)
25213             PMB=PM1+PM2+PM3-PMA-PMC
25214             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
25215             PMAN=PMA**2/SH
25216             PMBN=PMB**2/SH
25217             PMCN=PMC**2/SH
25218             PMBCN=PMBC**2/SH
25219             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
25220      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25221      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25222      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
25223      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25224      &      ((1D0-PMBCN)*PMBCN*SH)
25225           ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
25226             WDTP(I)=WDTP(I)*SQRT(
25227      &      MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
25228      &      MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
25229           ELSEIF(MDME(IDC,2).EQ.53) THEN
25230             PMA=MAX(PM1,PM2,PM3)
25231             PMC=MIN(PM1,PM2,PM3)
25232             PMB=PM1+PM2+PM3-PMA-PMC
25233             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
25234             PMAN=PMA**2/SH
25235             PMBN=PMB**2/SH
25236             PMCN=PMC**2/SH
25237             PMBCN=PMBC**2/SH
25238             FACACT=SQRT(MAX(0D0,
25239      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25240      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25241      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
25242      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25243      &      ((1D0-PMBCN)*PMBCN*SH)
25244             PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
25245             PMAN=PMA**2/PMR**2
25246             PMBN=PMB**2/PMR**2
25247             PMCN=PMC**2/PMR**2
25248             PMBCN=PMBC**2/PMR**2
25249             FACNOM=SQRT(MAX(0D0,
25250      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25251      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25252      &      ((PMR-PMA)**2-(PMB+PMC)**2)*
25253      &      (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
25254      &      ((1D0-PMBCN)*PMBCN*PMR**2)
25255             WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
25256           ENDIF
25257           WDTP(I)=FUDGE*WDTP(I)
25258           WDTP(0)=WDTP(0)+WDTP(I)
25259 
25260 C...Calculate secondary width (at most two identical/opposite).
25261           WID2=1D0
25262           IF(MDME(IDC,1).GT.0) THEN
25263             IF(KFD2.EQ.KFD1) THEN
25264               IF(KCHG(KFC1,3).EQ.0) THEN
25265                 WID2=WIDS(KFC1,1)
25266               ELSEIF(KFD1.GT.0) THEN
25267                 WID2=WIDS(KFC1,4)
25268               ELSE
25269                 WID2=WIDS(KFC1,5)
25270               ENDIF
25271               IF(KFD3.GT.0) THEN
25272                 WID2=WID2*WIDS(KFC3,2)
25273               ELSEIF(KFD3.LT.0) THEN
25274                 WID2=WID2*WIDS(KFC3,3)
25275               ENDIF
25276             ELSEIF(KFD2.EQ.-KFD1) THEN
25277               WID2=WIDS(KFC1,1)
25278               IF(KFD3.GT.0) THEN
25279                 WID2=WID2*WIDS(KFC3,2)
25280               ELSEIF(KFD3.LT.0) THEN
25281                 WID2=WID2*WIDS(KFC3,3)
25282               ENDIF
25283             ELSEIF(KFD3.EQ.KFD1) THEN
25284               IF(KCHG(KFC1,3).EQ.0) THEN
25285                 WID2=WIDS(KFC1,1)
25286               ELSEIF(KFD1.GT.0) THEN
25287                 WID2=WIDS(KFC1,4)
25288               ELSE
25289                 WID2=WIDS(KFC1,5)
25290               ENDIF
25291               IF(KFD2.GT.0) THEN
25292                 WID2=WID2*WIDS(KFC2,2)
25293               ELSEIF(KFD2.LT.0) THEN
25294                 WID2=WID2*WIDS(KFC2,3)
25295               ENDIF
25296             ELSEIF(KFD3.EQ.-KFD1) THEN
25297               WID2=WIDS(KFC1,1)
25298               IF(KFD2.GT.0) THEN
25299                 WID2=WID2*WIDS(KFC2,2)
25300               ELSEIF(KFD2.LT.0) THEN
25301                 WID2=WID2*WIDS(KFC2,3)
25302               ENDIF
25303             ELSEIF(KFD3.EQ.KFD2) THEN
25304               IF(KCHG(KFC2,3).EQ.0) THEN
25305                 WID2=WIDS(KFC2,1)
25306               ELSEIF(KFD2.GT.0) THEN
25307                 WID2=WIDS(KFC2,4)
25308               ELSE
25309                 WID2=WIDS(KFC2,5)
25310               ENDIF
25311               IF(KFD1.GT.0) THEN
25312                 WID2=WID2*WIDS(KFC1,2)
25313               ELSEIF(KFD1.LT.0) THEN
25314                 WID2=WID2*WIDS(KFC1,3)
25315               ENDIF
25316             ELSEIF(KFD3.EQ.-KFD2) THEN
25317               WID2=WIDS(KFC2,1)
25318               IF(KFD1.GT.0) THEN
25319                 WID2=WID2*WIDS(KFC1,2)
25320               ELSEIF(KFD1.LT.0) THEN
25321                 WID2=WID2*WIDS(KFC1,3)
25322               ENDIF
25323             ELSE
25324               IF(KFD1.GT.0) THEN
25325                 WID2=WIDS(KFC1,2)
25326               ELSE
25327                 WID2=WIDS(KFC1,3)
25328               ENDIF
25329               IF(KFD2.GT.0) THEN
25330                 WID2=WID2*WIDS(KFC2,2)
25331               ELSE
25332                 WID2=WID2*WIDS(KFC2,3)
25333               ENDIF
25334               IF(KFD3.GT.0) THEN
25335                 WID2=WID2*WIDS(KFC3,2)
25336               ELSEIF(KFD3.LT.0) THEN
25337                 WID2=WID2*WIDS(KFC3,3)
25338               ENDIF
25339             ENDIF
25340  
25341 C...Store effective widths according to case.
25342 C...PS: bug fix 16/2 2012 to avoid problems caused by adding 0.0*NaN
25343             IF (WDTP(I).GT.0D0) THEN
25344               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25345               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))
25346      &             +WDTE(I,MDME(IDC,1))
25347               WDTE(I,0)=WDTE(I,MDME(IDC,1))
25348               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25349             ELSE
25350               WDTE(I,MDME(IDC,1))= 0D0
25351               WDTE(I,0)= 0D0
25352             ENDIF
25353           ENDIF
25354   120   CONTINUE
25355 C...Return.
25356         MINT(61)=0
25357         MINT(62)=0
25358         MINT(63)=0
25359         RETURN
25360       ENDIF
25361  
25362 C...Here begins detailed dynamical calculation of resonance widths.
25363 C...Shared treatment of Higgs states.
25364       KFHIGG=25
25365       IHIGG=1
25366       IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25367         KFHIGG=KFLA
25368         IHIGG=KFLA-33
25369       ENDIF
25370  
25371 C...Common electroweak and strong constants.
25372       XW=PARU(102)
25373       XWV=XW
25374       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
25375       XW1=1D0-XW
25376       AEM=PYALEM(SH)
25377       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
25378       AS=PYALPS(SH)
25379       RADC=1D0+AS/PARU(1)
25380  
25381       IF(KFLA.EQ.6) THEN
25382 C...t quark.
25383         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25384         RADCT=1D0-2.5D0*AS/PARU(1)
25385         DO 140 I=1,MDCY(KC,3)
25386           IDC=I+MDCY(KC,2)-1
25387           IF(MDME(IDC,1).LT.0) GOTO 140
25388           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25389           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25390           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
25391           WID2=1D0
25392           IF(I.GE.4.AND.I.LE.7) THEN
25393 C...t -> W + q; including approximate QCD correction factor.
25394             WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
25395      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25396      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25397             IF(KFLR.GT.0) THEN
25398               WID2=WIDS(24,2)
25399               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25400             ELSE
25401               WID2=WIDS(24,3)
25402               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25403             ENDIF
25404           ELSEIF(I.EQ.9) THEN
25405 C...t -> H + b.
25406             RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25407             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25408      &      ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
25409      &      4D0*SQRT(RM2R*RM2))
25410             WID2=WIDS(37,2)
25411             IF(KFLR.LT.0) WID2=WIDS(37,3)
25412 CMRENNA++
25413           ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
25414 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
25415             BETA=ATAN(RMSS(5))
25416             SINB=SIN(BETA)
25417             TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25418             ET=KCHG(6,1)/3D0
25419             T3L=SIGN(0.5D0,ET)
25420             KFC1=PYCOMP(KFDP(IDC,1))
25421             KFC2=PYCOMP(KFDP(IDC,2))
25422             PMNCHI=PMAS(KFC1,1)
25423             PMSTOP=PMAS(KFC2,1)
25424             IF(SHR.GT.PMNCHI+PMSTOP) THEN
25425               IZ=I-9
25426               DO 130 IK=1,4
25427                 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
25428   130         CONTINUE
25429               AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
25430               AR=-ET*ZMIXC(IZ,1)*TANW
25431               BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
25432               BR=AL
25433               FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
25434               FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
25435               PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25436      &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25437               WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
25438      &        ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
25439      &        SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
25440               IF(KFLR.GT.0) THEN
25441                 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25442               ELSE
25443                 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25444               ENDIF
25445             ENDIF
25446           ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
25447 C...t -> ~g + ~t
25448             KFC1=PYCOMP(KFDP(IDC,1))
25449             KFC2=PYCOMP(KFDP(IDC,2))
25450             PMNCHI=PMAS(KFC1,1)
25451             PMSTOP=PMAS(KFC2,1)
25452             IF(SHR.GT.PMNCHI+PMSTOP) THEN
25453               RL=SFMIX(6,1)
25454               RR=-SFMIX(6,2)
25455               PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25456      &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25457               WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
25458      &        (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
25459               IF(KFLR.GT.0) THEN
25460                 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25461               ELSE
25462                 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25463               ENDIF
25464             ENDIF
25465           ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
25466 C...t -> ~gravitino + ~t
25467             XMP2=RMSS(29)**2
25468             KFC1=PYCOMP(KFDP(IDC,1))
25469             XMGR2=PMAS(KFC1,1)**2
25470             WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
25471             KFC2=PYCOMP(KFDP(IDC,2))
25472             WID2=WIDS(KFC2,2)
25473             IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
25474 CMRENNA--
25475           ENDIF
25476           WDTP(I)=FUDGE*WDTP(I)
25477           WDTP(0)=WDTP(0)+WDTP(I)
25478           IF(MDME(IDC,1).GT.0) THEN
25479             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25480             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25481             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25482             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25483           ENDIF
25484   140   CONTINUE
25485  
25486       ELSEIF(KFLA.EQ.7) THEN
25487 C...b' quark.
25488         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25489         DO 150 I=1,MDCY(KC,3)
25490           IDC=I+MDCY(KC,2)-1
25491           IF(MDME(IDC,1).LT.0) GOTO 150
25492           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25493           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25494           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
25495           WID2=1D0
25496           IF(I.GE.4.AND.I.LE.7) THEN
25497 C...b' -> W + q.
25498             WDTP(I)=FAC*VCKM(I-3,4)*
25499      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25500      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25501             IF(KFLR.GT.0) THEN
25502               WID2=WIDS(24,3)
25503               IF(I.EQ.6) WID2=WID2*WIDS(6,2)
25504               IF(I.EQ.7) WID2=WID2*WIDS(8,2)
25505             ELSE
25506               WID2=WIDS(24,2)
25507               IF(I.EQ.6) WID2=WID2*WIDS(6,3)
25508               IF(I.EQ.7) WID2=WID2*WIDS(8,3)
25509             ENDIF
25510             WID2=WIDS(24,3)
25511             IF(KFLR.LT.0) WID2=WIDS(24,2)
25512           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25513 C...b' -> H + q.
25514             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25515      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25516             IF(KFLR.GT.0) THEN
25517               WID2=WIDS(37,3)
25518               IF(I.EQ.10) WID2=WID2*WIDS(6,2)
25519             ELSE
25520               WID2=WIDS(37,2)
25521               IF(I.EQ.10) WID2=WID2*WIDS(6,3)
25522             ENDIF
25523           ENDIF
25524           WDTP(I)=FUDGE*WDTP(I)
25525           WDTP(0)=WDTP(0)+WDTP(I)
25526           IF(MDME(IDC,1).GT.0) THEN
25527             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25528             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25529             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25530             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25531           ENDIF
25532   150   CONTINUE
25533  
25534       ELSEIF(KFLA.EQ.8) THEN
25535 C...t' quark.
25536         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25537         DO 160 I=1,MDCY(KC,3)
25538           IDC=I+MDCY(KC,2)-1
25539           IF(MDME(IDC,1).LT.0) GOTO 160
25540           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25541           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25542           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
25543           WID2=1D0
25544           IF(I.GE.4.AND.I.LE.7) THEN
25545 C...t' -> W + q.
25546             WDTP(I)=FAC*VCKM(4,I-3)*
25547      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25548      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25549             IF(KFLR.GT.0) THEN
25550               WID2=WIDS(24,2)
25551               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25552             ELSE
25553               WID2=WIDS(24,3)
25554               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25555             ENDIF
25556           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25557 C...t' -> H + q.
25558             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25559      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25560             IF(KFLR.GT.0) THEN
25561               WID2=WIDS(37,2)
25562               IF(I.EQ.10) WID2=WID2*WIDS(7,2)
25563             ELSE
25564               WID2=WIDS(37,3)
25565               IF(I.EQ.10) WID2=WID2*WIDS(7,3)
25566             ENDIF
25567           ENDIF
25568           WDTP(I)=FUDGE*WDTP(I)
25569           WDTP(0)=WDTP(0)+WDTP(I)
25570           IF(MDME(IDC,1).GT.0) THEN
25571             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25572             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25573             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25574             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25575           ENDIF
25576   160   CONTINUE
25577  
25578       ELSEIF(KFLA.EQ.17) THEN
25579 C...tau' lepton.
25580         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25581         DO 170 I=1,MDCY(KC,3)
25582           IDC=I+MDCY(KC,2)-1
25583           IF(MDME(IDC,1).LT.0) GOTO 170
25584           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25585           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25586           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
25587           WID2=1D0
25588           IF(I.EQ.3) THEN
25589 C...tau' -> W + nu'_tau.
25590             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25591      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25592             IF(KFLR.GT.0) THEN
25593               WID2=WIDS(24,3)
25594               WID2=WID2*WIDS(18,2)
25595             ELSE
25596               WID2=WIDS(24,2)
25597               WID2=WID2*WIDS(18,3)
25598             ENDIF
25599           ELSEIF(I.EQ.5) THEN
25600 C...tau' -> H + nu'_tau.
25601             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25602      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25603             IF(KFLR.GT.0) THEN
25604               WID2=WIDS(37,3)
25605               WID2=WID2*WIDS(18,2)
25606             ELSE
25607               WID2=WIDS(37,2)
25608               WID2=WID2*WIDS(18,3)
25609             ENDIF
25610           ENDIF
25611           WDTP(I)=FUDGE*WDTP(I)
25612           WDTP(0)=WDTP(0)+WDTP(I)
25613           IF(MDME(IDC,1).GT.0) THEN
25614             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25615             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25616             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25617             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25618           ENDIF
25619   170   CONTINUE
25620  
25621       ELSEIF(KFLA.EQ.18) THEN
25622 C...nu'_tau neutrino.
25623         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25624         DO 180 I=1,MDCY(KC,3)
25625           IDC=I+MDCY(KC,2)-1
25626           IF(MDME(IDC,1).LT.0) GOTO 180
25627           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25628           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25629           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
25630           WID2=1D0
25631           IF(I.EQ.2) THEN
25632 C...nu'_tau -> W + tau'.
25633             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25634      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25635             IF(KFLR.GT.0) THEN
25636               WID2=WIDS(24,2)
25637               WID2=WID2*WIDS(17,2)
25638             ELSE
25639               WID2=WIDS(24,3)
25640               WID2=WID2*WIDS(17,3)
25641             ENDIF
25642           ELSEIF(I.EQ.3) THEN
25643 C...nu'_tau -> H + tau'.
25644             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25645      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25646             IF(KFLR.GT.0) THEN
25647               WID2=WIDS(37,2)
25648               WID2=WID2*WIDS(17,2)
25649             ELSE
25650               WID2=WIDS(37,3)
25651               WID2=WID2*WIDS(17,3)
25652             ENDIF
25653           ENDIF
25654           WDTP(I)=FUDGE*WDTP(I)
25655           WDTP(0)=WDTP(0)+WDTP(I)
25656           IF(MDME(IDC,1).GT.0) THEN
25657             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25658             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25659             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25660             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25661           ENDIF
25662   180   CONTINUE
25663  
25664       ELSEIF(KFLA.EQ.21) THEN
25665 C...QCD:
25666 C***Note that widths are not given in dimensional quantities here.
25667         DO 190 I=1,MDCY(KC,3)
25668           IDC=I+MDCY(KC,2)-1
25669           IF(MDME(IDC,1).LT.0) GOTO 190
25670           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25671           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25672           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25673           WID2=1D0
25674           IF(I.LE.8) THEN
25675 C...QCD -> q + qbar
25676             WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25677             IF(I.EQ.6) WID2=WIDS(6,1)
25678             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25679           ENDIF
25680           WDTP(I)=FUDGE*WDTP(I)
25681           WDTP(0)=WDTP(0)+WDTP(I)
25682           IF(MDME(IDC,1).GT.0) THEN
25683             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25684             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25685             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25686             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25687           ENDIF
25688   190   CONTINUE
25689  
25690       ELSEIF(KFLA.EQ.22) THEN
25691 C...QED photon.
25692 C***Note that widths are not given in dimensional quantities here.
25693         DO 200 I=1,MDCY(KC,3)
25694           IDC=I+MDCY(KC,2)-1
25695           IF(MDME(IDC,1).LT.0) GOTO 200
25696           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25697           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25698           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25699           WID2=1D0
25700           IF(I.LE.8) THEN
25701 C...QED -> q + qbar.
25702             EF=KCHG(I,1)/3D0
25703             FCOF=3D0*RADC
25704             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25705             WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25706             IF(I.EQ.6) WID2=WIDS(6,1)
25707             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25708           ELSEIF(I.LE.12) THEN
25709 C...QED -> l+ + l-.
25710             EF=KCHG(9+2*(I-8),1)/3D0
25711             WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25712             IF(I.EQ.12) WID2=WIDS(17,1)
25713           ENDIF
25714           WDTP(I)=FUDGE*WDTP(I)
25715           WDTP(0)=WDTP(0)+WDTP(I)
25716           IF(MDME(IDC,1).GT.0) THEN
25717             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25718             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25719             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25720             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25721           ENDIF
25722   200   CONTINUE
25723  
25724       ELSEIF(KFLA.EQ.23) THEN
25725 C...Z0:
25726         ICASE=1
25727         XWC=1D0/(16D0*XW*XW1)
25728         FAC=(AEM*XWC/3D0)*SHR
25729   210   CONTINUE
25730         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25731           VINT(111)=0D0
25732           VINT(112)=0D0
25733           VINT(114)=0D0
25734         ENDIF
25735         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25736           KFI=IABS(MINT(15))
25737           IF(KFI.GT.20) KFI=IABS(MINT(16))
25738           EI=KCHG(KFI,1)/3D0
25739           AI=SIGN(1D0,EI)
25740           VI=AI-4D0*EI*XWV
25741           SQMZ=PMAS(23,1)**2
25742           HZ=SHR*WDTP(0)
25743           IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25744           IF(MSTP(43).EQ.3) VINT(112)=
25745      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25746           IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25747      &    XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25748         ENDIF
25749         DO 220 I=1,MDCY(KC,3)
25750           IDC=I+MDCY(KC,2)-1
25751           IF(MDME(IDC,1).LT.0) GOTO 220
25752           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25753           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25754           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25755           WID2=1D0
25756           IF(I.LE.8) THEN
25757 C...Z0 -> q + qbar
25758             EF=KCHG(I,1)/3D0
25759             AF=SIGN(1D0,EF+0.1D0)
25760             VF=AF-4D0*EF*XWV
25761             FCOF=3D0*RADC
25762             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25763             IF(I.EQ.6) WID2=WIDS(6,1)
25764             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25765           ELSEIF(I.LE.16) THEN
25766 C...Z0 -> l+ + l-, nu + nubar
25767             EF=KCHG(I+2,1)/3D0
25768             AF=SIGN(1D0,EF+0.1D0)
25769             VF=AF-4D0*EF*XWV
25770             FCOF=1D0
25771             IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25772           ENDIF
25773           BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25774           IF(ICASE.EQ.1) THEN
25775             WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25776      &      BE34
25777           ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25778             WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25779      &      EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25780      &      (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25781           ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25782             FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25783             FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25784             FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25785           ENDIF
25786           IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25787           IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25788           IF(MDME(IDC,1).GT.0) THEN
25789             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25790      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25791               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25792               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25793      &        WDTE(I,MDME(IDC,1))
25794               WDTE(I,0)=WDTE(I,MDME(IDC,1))
25795               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25796             ENDIF
25797             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25798               IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25799      &        VINT(111)+FGGF*WID2
25800               IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25801               IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25802      &        VINT(114)+FZZF*WID2
25803             ENDIF
25804           ENDIF
25805   220   CONTINUE
25806         IF(MINT(61).GE.1) ICASE=3-ICASE
25807         IF(ICASE.EQ.2) GOTO 210
25808  
25809       ELSEIF(KFLA.EQ.24) THEN
25810 C...W+/-:
25811         FAC=(AEM/(24D0*XW))*SHR
25812         DO 230 I=1,MDCY(KC,3)
25813           IDC=I+MDCY(KC,2)-1
25814           IF(MDME(IDC,1).LT.0) GOTO 230
25815           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25816           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25817           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25818           WID2=1D0
25819           IF(I.LE.16) THEN
25820 C...W+/- -> q + qbar'
25821             FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25822             IF(KFLR.GT.0) THEN
25823               IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25824               IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25825               IF(I.GE.13) WID2=WID2*WIDS(7,3)
25826             ELSE
25827               IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25828               IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25829               IF(I.GE.13) WID2=WID2*WIDS(7,2)
25830             ENDIF
25831           ELSEIF(I.LE.20) THEN
25832 C...W+/- -> l+/- + nu
25833             FCOF=1D0
25834             IF(KFLR.GT.0) THEN
25835               IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25836             ELSE
25837               IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25838             ENDIF
25839           ENDIF
25840           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25841      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25842           WDTP(I)=FUDGE*WDTP(I)
25843           WDTP(0)=WDTP(0)+WDTP(I)
25844           IF(MDME(IDC,1).GT.0) THEN
25845             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25846             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25847             WDTE(I,0)=WDTE(I,MDME(IDC,1))
25848             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25849           ENDIF
25850   230   CONTINUE
25851  
25852       ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25853 C...h0 (or H0, or A0):
25854         SHFS=SH
25855         FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25856         DO 270 I=1,MDCY(KFHIGG,3)
25857           IDC=I+MDCY(KFHIGG,2)-1
25858           IF(MDME(IDC,1).LT.0) GOTO 270
25859           KFC1=PYCOMP(KFDP(IDC,1))
25860           KFC2=PYCOMP(KFDP(IDC,2))
25861           RM1=PMAS(KFC1,1)**2/SH
25862           RM2=PMAS(KFC2,1)**2/SH
25863           IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25864      &    GOTO 270
25865           WID2=1D0
25866  
25867           IF(I.LE.8) THEN
25868 C...h0 -> q + qbar
25869             WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25870      &      SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25871 C...A0 behaves like beta, ho and H0 like beta**3.
25872             IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25873             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25874               IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25875               IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25876               IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25877                 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25878                 IF(IHIGG.NE.3) THEN
25879                   WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25880      &            PARU(151+10*IHIGG))**2
25881                 ENDIF
25882               ENDIF
25883             ENDIF
25884             IF(I.EQ.6) WID2=WIDS(6,1)
25885             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25886           ELSEIF(I.LE.12) THEN
25887 C...h0 -> l+ + l-
25888             WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25889 C...A0 behaves like beta, ho and H0 like beta**3.
25890             IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25891             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25892      &      PARU(153+10*IHIGG)**2
25893             IF(I.EQ.12) WID2=WIDS(17,1)
25894  
25895           ELSEIF(I.EQ.13) THEN
25896 C...h0 -> g + g; quark loop contribution only
25897             ETARE=0D0
25898             ETAIM=0D0
25899             DO 240 J=1,2*MSTP(1)
25900               EPS=(2D0*PMAS(J,1))**2/SH
25901 C...Loop integral; function of eps=4m^2/shat; different for A0.
25902               IF(EPS.LE.1D0) THEN
25903                 IF(EPS.GT.1D-4) THEN
25904                   ROOT=SQRT(1D0-EPS)
25905                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25906                 ELSE
25907                   RLN=LOG(4D0/EPS-2D0)
25908                 ENDIF
25909                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25910                 PHIIM=0.5D0*PARU(1)*RLN
25911               ELSE
25912                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25913                 PHIIM=0D0
25914               ENDIF
25915               IF(IHIGG.LE.2) THEN
25916                 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25917                 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25918               ELSE
25919                 ETAREJ=-0.5D0*EPS*PHIRE
25920                 ETAIMJ=-0.5D0*EPS*PHIIM
25921               ENDIF
25922 C...Couplings (=1 for standard model Higgs).
25923               IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25924                 IF(MOD(J,2).EQ.1) THEN
25925                   ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25926                   ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25927                 ELSE
25928                   ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25929                   ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25930                 ENDIF
25931               ENDIF
25932               ETARE=ETARE+ETAREJ
25933               ETAIM=ETAIM+ETAIMJ
25934   240       CONTINUE
25935             ETA2=ETARE**2+ETAIM**2
25936             WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25937  
25938           ELSEIF(I.EQ.14) THEN
25939 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25940             ETARE=0D0
25941             ETAIM=0D0
25942             JMAX=3*MSTP(1)+1
25943             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25944             DO 250 J=1,JMAX
25945               IF(J.LE.2*MSTP(1)) THEN
25946                 EJ=KCHG(J,1)/3D0
25947                 EPS=(2D0*PMAS(J,1))**2/SH
25948               ELSEIF(J.LE.3*MSTP(1)) THEN
25949                 JL=2*(J-2*MSTP(1))-1
25950                 EJ=KCHG(10+JL,1)/3D0
25951                 EPS=(2D0*PMAS(10+JL,1))**2/SH
25952               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25953                 EPS=(2D0*PMAS(24,1))**2/SH
25954               ELSE
25955                 EPS=(2D0*PMAS(37,1))**2/SH
25956               ENDIF
25957 C...Loop integral; function of eps=4m^2/shat.
25958               IF(EPS.LE.1D0) THEN
25959                 IF(EPS.GT.1D-4) THEN
25960                   ROOT=SQRT(1D0-EPS)
25961                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25962                 ELSE
25963                   RLN=LOG(4D0/EPS-2D0)
25964                 ENDIF
25965                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25966                 PHIIM=0.5D0*PARU(1)*RLN
25967               ELSE
25968                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25969                 PHIIM=0D0
25970               ENDIF
25971               IF(J.LE.3*MSTP(1)) THEN
25972 C...Fermion loops: loop integral different for A0; charges.
25973                 IF(IHIGG.LE.2) THEN
25974                   PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25975                   PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25976                 ELSE
25977                   PHIPRE=-0.5D0*EPS*PHIRE
25978                   PHIPIM=-0.5D0*EPS*PHIIM
25979                 ENDIF
25980                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25981                   EJC=3D0*EJ**2
25982                   EJH=PARU(151+10*IHIGG)
25983                 ELSEIF(J.LE.2*MSTP(1)) THEN
25984                   EJC=3D0*EJ**2
25985                   EJH=PARU(152+10*IHIGG)
25986                 ELSE
25987                   EJC=EJ**2
25988                   EJH=PARU(153+10*IHIGG)
25989                 ENDIF
25990                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25991                 ETAREJ=EJC*EJH*PHIPRE
25992                 ETAIMJ=EJC*EJH*PHIPIM
25993               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25994 C...W loops: loop integral and charges.
25995                 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25996                 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25997                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25998                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25999                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26000                 ENDIF
26001               ELSE
26002 C...Charged H loops: loop integral and charges.
26003                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
26004      &          PARU(158+10*IHIGG+2*(IHIGG/3))
26005                 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
26006                 ETAIMJ=-EPS**2*PHIIM*FACHHH
26007               ENDIF
26008               ETARE=ETARE+ETAREJ
26009               ETAIM=ETAIM+ETAIMJ
26010   250       CONTINUE
26011             ETA2=ETARE**2+ETAIM**2
26012             WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
26013  
26014           ELSEIF(I.EQ.15) THEN
26015 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
26016             ETARE=0D0
26017             ETAIM=0D0
26018             JMAX=3*MSTP(1)+1
26019             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
26020             DO 260 J=1,JMAX
26021               IF(J.LE.2*MSTP(1)) THEN
26022                 EJ=KCHG(J,1)/3D0
26023                 AJ=SIGN(1D0,EJ+0.1D0)
26024                 VJ=AJ-4D0*EJ*XWV
26025                 EPS=(2D0*PMAS(J,1))**2/SH
26026                 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
26027               ELSEIF(J.LE.3*MSTP(1)) THEN
26028                 JL=2*(J-2*MSTP(1))-1
26029                 EJ=KCHG(10+JL,1)/3D0
26030                 AJ=SIGN(1D0,EJ+0.1D0)
26031                 VJ=AJ-4D0*EJ*XWV
26032                 EPS=(2D0*PMAS(10+JL,1))**2/SH
26033                 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
26034               ELSE
26035                 EPS=(2D0*PMAS(24,1))**2/SH
26036                 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
26037               ENDIF
26038 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
26039               IF(EPS.LE.1D0) THEN
26040                 ROOT=SQRT(1D0-EPS)
26041                 IF(EPS.GT.1D-4) THEN
26042                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26043                 ELSE
26044                   RLN=LOG(4D0/EPS-2D0)
26045                 ENDIF
26046                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
26047                 PHIIM=0.5D0*PARU(1)*RLN
26048                 PSIRE=0.5D0*ROOT*RLN
26049                 PSIIM=-0.5D0*ROOT*PARU(1)
26050               ELSE
26051                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
26052                 PHIIM=0D0
26053                 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
26054                 PSIIM=0D0
26055               ENDIF
26056               IF(EPSP.LE.1D0) THEN
26057                 ROOT=SQRT(1D0-EPSP)
26058                 IF(EPSP.GT.1D-4) THEN
26059                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26060                 ELSE
26061                   RLN=LOG(4D0/EPSP-2D0)
26062                 ENDIF
26063                 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
26064                 PHIIMP=0.5D0*PARU(1)*RLN
26065                 PSIREP=0.5D0*ROOT*RLN
26066                 PSIIMP=-0.5D0*ROOT*PARU(1)
26067               ELSE
26068                 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
26069                 PHIIMP=0D0
26070                 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
26071                 PSIIMP=0D0
26072               ENDIF
26073               FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
26074      &        (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
26075               FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
26076      &        (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
26077               F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
26078               F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
26079               IF(J.LE.3*MSTP(1)) THEN
26080 C...Fermion loops: loop integral different for A0; charges.
26081                 IF(IHIGG.EQ.3) FXYRE=0D0
26082                 IF(IHIGG.EQ.3) FXYIM=0D0
26083                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
26084                   EJC=-3D0*EJ*VJ
26085                   EJH=PARU(151+10*IHIGG)
26086                 ELSEIF(J.LE.2*MSTP(1)) THEN
26087                   EJC=-3D0*EJ*VJ
26088                   EJH=PARU(152+10*IHIGG)
26089                 ELSE
26090                   EJC=-EJ*VJ
26091                   EJH=PARU(153+10*IHIGG)
26092                 ENDIF
26093                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26094                 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
26095                 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
26096               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26097 C...W loops: loop integral and charges.
26098                 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
26099                 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
26100                 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
26101                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26102                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26103                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26104                 ENDIF
26105               ELSE
26106 C...Charged H loops: loop integral and charges.
26107                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
26108      &          PARU(158+10*IHIGG+2*(IHIGG/3))
26109                 ETAREJ=FACHHH*FXYRE
26110                 ETAIMJ=FACHHH*FXYIM
26111               ENDIF
26112               ETARE=ETARE+ETAREJ
26113               ETAIM=ETAIM+ETAIMJ
26114   260       CONTINUE
26115             ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
26116             WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
26117             WID2=WIDS(23,2)
26118  
26119           ELSEIF(I.LE.17) THEN
26120 C...h0 -> Z0 + Z0, W+ + W-
26121             PM1=PMAS(IABS(KFDP(IDC,1)),1)
26122             PG1=PMAS(IABS(KFDP(IDC,1)),2)
26123             IF(MINT(62).GE.1) THEN
26124               IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
26125      &        CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
26126      &        MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
26127                 MOFSV(IHIGG,I-15)=0
26128                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26129      &          1D0-4D0*RM1))
26130                 WID2=1D0
26131               ELSE
26132                 MOFSV(IHIGG,I-15)=1
26133                 RMAS=SQRT(MAX(0D0,SH))
26134                 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
26135      &          WID2)
26136                 WIDWSV(IHIGG,I-15)=WIDW
26137                 WID2SV(IHIGG,I-15)=WID2
26138               ENDIF
26139             ELSE
26140               IF(MOFSV(IHIGG,I-15).EQ.0) THEN
26141                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26142      &          1D0-4D0*RM1))
26143                 WID2=1D0
26144               ELSE
26145                 WIDW=WIDWSV(IHIGG,I-15)
26146                 WID2=WID2SV(IHIGG,I-15)
26147               ENDIF
26148             ENDIF
26149             WDTP(I)=FAC*WIDW/(2D0*(18-I))
26150             IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
26151             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
26152      &      PARU(138+I+10*IHIGG)**2
26153             WID2=WID2*WIDS(7+I,1)
26154  
26155           ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
26156 C...H0 -> Z0 + h0, A0-> Z0 + h0
26157             WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26158      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26159             IF(IHIGG.EQ.2) THEN
26160              WDTP(I)=WDTP(I)*PARU(179)**2
26161             ELSEIF(IHIGG.EQ.3) THEN
26162              WDTP(I)=WDTP(I)*PARU(186)**2
26163             ENDIF
26164             WID2=WIDS(23,2)*WIDS(25,2)
26165  
26166           ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
26167 C...H0 -> h0 + h0, A0-> h0 + h0
26168             WDTP(I)=FAC*0.25D0*
26169      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26170             IF(IHIGG.EQ.2) THEN
26171              WDTP(I)=WDTP(I)*PARU(176)**2
26172             ELSEIF(IHIGG.EQ.3) THEN
26173              WDTP(I)=WDTP(I)*PARU(169)**2
26174             ENDIF
26175             WID2=WIDS(25,1)
26176           ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
26177 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
26178             WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26179      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26180      &      *PARU(195+IHIGG)**2
26181             IF(I.EQ.20) THEN
26182               WID2=WIDS(24,2)*WIDS(37,3)
26183             ELSEIF(I.EQ.21) THEN
26184               WID2=WIDS(24,3)*WIDS(37,2)
26185             ENDIF
26186  
26187           ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
26188 C...H0 -> Z0 + A0.
26189             WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
26190      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26191             WID2=WIDS(36,2)*WIDS(23,2)
26192  
26193           ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
26194 C...H0 -> h0 + A0.
26195             WDTP(I)=FAC*0.5D0*PARU(180)**2*
26196      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26197             WID2=WIDS(25,2)*WIDS(36,2)
26198  
26199           ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
26200 C...H0 -> A0 + A0
26201             WDTP(I)=FAC*0.25D0*PARU(177)**2*
26202      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26203             WID2=WIDS(36,1)
26204  
26205 CMRENNA++
26206           ELSE
26207 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26208             RM10=RM1*SH/PMR**2
26209             RM20=RM2*SH/PMR**2
26210             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26211             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26212             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26213               WFAC=0D0
26214             ELSE
26215               WFAC=WFAC/WFAC0
26216             ENDIF
26217             WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26218 CMRENNA--
26219             IF(KFC2.EQ.KFC1) THEN
26220               WID2=WIDS(KFC1,1)
26221             ELSE
26222               KSGN1=2
26223               IF(KFDP(IDC,1).LT.0) KSGN1=3
26224               KSGN2=2
26225               IF(KFDP(IDC,2).LT.0) KSGN2=3
26226               WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26227             ENDIF
26228           ENDIF
26229           WDTP(I)=FUDGE*WDTP(I)
26230           WDTP(0)=WDTP(0)+WDTP(I)
26231           IF(MDME(IDC,1).GT.0) THEN
26232             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26233             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26234             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26235             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26236           ENDIF
26237   270   CONTINUE
26238  
26239       ELSEIF(KFLA.EQ.32) THEN
26240 C...Z'0:
26241         ICASE=1
26242         XWC=1D0/(16D0*XW*XW1)
26243         FAC=(AEM*XWC/3D0)*SHR
26244         VINT(117)=0D0
26245   280   CONTINUE
26246         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
26247           VINT(111)=0D0
26248           VINT(112)=0D0
26249           VINT(113)=0D0
26250           VINT(114)=0D0
26251           VINT(115)=0D0
26252           VINT(116)=0D0
26253         ENDIF
26254         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26255           KFAI=IABS(MINT(15))
26256           EI=KCHG(KFAI,1)/3D0
26257           AI=SIGN(1D0,EI+0.1D0)
26258           VI=AI-4D0*EI*XWV
26259           KFAIC=1
26260           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
26261           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
26262           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
26263           IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
26264             VPI=PARU(119+2*KFAIC)
26265             API=PARU(120+2*KFAIC)
26266           ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
26267             VPI=PARJ(178+2*KFAIC)
26268             API=PARJ(179+2*KFAIC)
26269           ELSE
26270             VPI=PARJ(186+2*KFAIC)
26271             API=PARJ(187+2*KFAIC)
26272           ENDIF
26273           SQMZ=PMAS(23,1)**2
26274           HZ=SHR*VINT(117)
26275           SQMZP=PMAS(32,1)**2
26276           HZP=SHR*WDTP(0)
26277           IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26278      &    MSTP(44).EQ.7) VINT(111)=1D0
26279           IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
26280      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
26281           IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
26282      &    2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
26283           IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26284      &    MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
26285           IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
26286      &    2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
26287      &    (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
26288           IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26289      &    MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
26290         ENDIF
26291         DO 290 I=1,MDCY(KC,3)
26292           IDC=I+MDCY(KC,2)-1
26293           IF(MDME(IDC,1).LT.0) GOTO 290
26294           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26295           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26296           IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
26297           WID2=1D0
26298           IF(I.LE.16) THEN
26299             IF(I.LE.8) THEN
26300 C...Z'0 -> q + qbar
26301               EF=KCHG(I,1)/3D0
26302               AF=SIGN(1D0,EF+0.1D0)
26303               VF=AF-4D0*EF*XWV
26304               IF(I.LE.2) THEN
26305                 VPF=PARU(123-2*MOD(I,2))
26306                 APF=PARU(124-2*MOD(I,2))
26307               ELSEIF(I.LE.4) THEN
26308                 VPF=PARJ(182-2*MOD(I,2))
26309                 APF=PARJ(183-2*MOD(I,2))
26310               ELSE
26311                 VPF=PARJ(190-2*MOD(I,2))
26312                 APF=PARJ(191-2*MOD(I,2))
26313               ENDIF
26314               FCOF=3D0*RADC
26315               IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26316      &        PYHFTH(SH,SH*RM1,1D0)
26317               IF(I.EQ.6) WID2=WIDS(6,1)
26318               IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
26319             ELSEIF(I.LE.16) THEN
26320 C...Z'0 -> l+ + l-, nu + nubar
26321               EF=KCHG(I+2,1)/3D0
26322               AF=SIGN(1D0,EF+0.1D0)
26323               VF=AF-4D0*EF*XWV
26324               IF(I.LE.10) THEN
26325                 VPF=PARU(127-2*MOD(I,2))
26326                 APF=PARU(128-2*MOD(I,2))
26327               ELSEIF(I.LE.12) THEN
26328                 VPF=PARJ(186-2*MOD(I,2))
26329                 APF=PARJ(187-2*MOD(I,2))
26330               ELSE
26331                 VPF=PARJ(194-2*MOD(I,2))
26332                 APF=PARJ(195-2*MOD(I,2))
26333               ENDIF
26334               FCOF=1D0
26335               IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
26336             ENDIF
26337             BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
26338             IF(ICASE.EQ.1) THEN
26339               WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26340               WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
26341      &        APF**2*(1D0-4D0*RM1))*BE34
26342             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26343               WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
26344      &        EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
26345      &        VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
26346      &        VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
26347      &        AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
26348      &        VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
26349             ELSEIF(MINT(61).EQ.2) THEN
26350               FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
26351               FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
26352               FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
26353               FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26354               FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
26355      &        BE34
26356               FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
26357      &        BE34
26358             ENDIF
26359           ELSEIF(I.EQ.17) THEN
26360 C...Z'0 -> W+ + W-
26361             WDTPZP=PARU(129)**2*XW1**2*
26362      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26363      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26364             IF(ICASE.EQ.1) THEN
26365               WDTPZ=0D0
26366               WDTP(I)=FAC*WDTPZP
26367             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26368               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26369             ELSEIF(MINT(61).EQ.2) THEN
26370               FGGF=0D0
26371               FGZF=0D0
26372               FGZPF=0D0
26373               FZZF=0D0
26374               FZZPF=0D0
26375               FZPZPF=WDTPZP
26376             ENDIF
26377             WID2=WIDS(24,1)
26378           ELSEIF(I.EQ.18) THEN
26379 C...Z'0 -> H+ + H-
26380             CZC=2D0*(1D0-2D0*XW)
26381             BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
26382             IF(ICASE.EQ.1) THEN
26383               WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
26384               WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
26385             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26386               WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
26387      &        VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
26388      &        (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
26389      &        (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
26390      &        (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
26391             ELSEIF(MINT(61).EQ.2) THEN
26392               FGGF=0.25D0*BE34C
26393               FGZF=0.25D0*PARU(142)*CZC*BE34C
26394               FGZPF=0.25D0*PARU(143)*CZC*BE34C
26395               FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
26396               FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
26397               FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
26398             ENDIF
26399             WID2=WIDS(37,1)
26400           ELSEIF(I.EQ.19) THEN
26401 C...Z'0 -> Z0 + gamma.
26402           ELSEIF(I.EQ.20) THEN
26403 C...Z'0 -> Z0 + h0
26404             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26405             WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
26406      &      (3D0*RM1+0.25D0*FLAM**2)*FLAM
26407             IF(ICASE.EQ.1) THEN
26408               WDTPZ=0D0
26409               WDTP(I)=FAC*WDTPZP
26410             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26411               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26412             ELSEIF(MINT(61).EQ.2) THEN
26413               FGGF=0D0
26414               FGZF=0D0
26415               FGZPF=0D0
26416               FZZF=0D0
26417               FZZPF=0D0
26418               FZPZPF=WDTPZP
26419             ENDIF
26420             WID2=WIDS(23,2)*WIDS(25,2)
26421           ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
26422 C...Z' -> h0 + A0 or H0 + A0.
26423             BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26424             IF(I.EQ.21) THEN
26425               CZAH=PARU(186)
26426               CZPAH=PARU(188)
26427             ELSE
26428               CZAH=PARU(187)
26429               CZPAH=PARU(189)
26430             ENDIF
26431             IF(ICASE.EQ.1) THEN
26432               WDTPZ=CZAH**2*BE34C
26433               WDTP(I)=FAC*CZPAH**2*BE34C
26434             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26435               WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
26436      &        (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
26437      &        VINT(116))*BE34C
26438             ELSEIF(MINT(61).EQ.2) THEN
26439               FGGF=0D0
26440               FGZF=0D0
26441               FGZPF=0D0
26442               FZZF=CZAH**2*BE34C
26443               FZZPF=CZAH*CZPAH*BE34C
26444               FZPZPF=CZPAH**2*BE34C
26445             ENDIF
26446             IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
26447             IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
26448           ENDIF
26449           IF(ICASE.EQ.1) THEN
26450             VINT(117)=VINT(117)+FAC*WDTPZ
26451             WDTP(I)=FUDGE*WDTP(I)
26452             WDTP(0)=WDTP(0)+WDTP(I)
26453           ENDIF
26454           IF(MDME(IDC,1).GT.0) THEN
26455             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
26456      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
26457               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26458               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
26459      &        WDTE(I,MDME(IDC,1))
26460               WDTE(I,0)=WDTE(I,MDME(IDC,1))
26461               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26462             ENDIF
26463             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
26464               IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26465      &        MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
26466               IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
26467      &        FGZF*WID2
26468               IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
26469      &        FGZPF*WID2
26470               IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26471      &        MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
26472               IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
26473      &        FZZPF*WID2
26474               IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26475      &        MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
26476             ENDIF
26477           ENDIF
26478   290   CONTINUE
26479         IF(MINT(61).GE.1) ICASE=3-ICASE
26480         IF(ICASE.EQ.2) GOTO 280
26481  
26482       ELSEIF(KFLA.EQ.34) THEN
26483 C...W'+/-:
26484         FAC=(AEM/(24D0*XW))*SHR
26485         DO 300 I=1,MDCY(KC,3)
26486           IDC=I+MDCY(KC,2)-1
26487           IF(MDME(IDC,1).LT.0) GOTO 300
26488           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26489           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26490           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
26491           WID2=1D0
26492           IF(I.LE.20) THEN
26493             IF(I.LE.16) THEN
26494 C...W'+/- -> q + qbar'
26495               CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
26496               FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
26497               FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
26498               IF(KFLR.GT.0) THEN
26499                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
26500                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
26501                 IF(I.GE.13) WID2=WID2*WIDS(7,3)
26502               ELSE
26503                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
26504                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
26505                 IF(I.GE.13) WID2=WID2*WIDS(7,2)
26506               ENDIF
26507             ELSEIF(I.LE.20) THEN
26508 C...W'+/- -> l+/- + nu
26509               FCOF=PARU(133)**2+PARU(134)**2
26510               FCOF2=PARU(133)**2-PARU(134)**2
26511               IF(KFLR.GT.0) THEN
26512                 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26513               ELSE
26514                 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26515               ENDIF
26516             ENDIF
26517             WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
26518      &           *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))     
26519             IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
26520 C...PS 28/06/2010
26521 C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
26522               WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
26523      &             *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) 
26524             ENDIF
26525           ELSEIF(I.EQ.21) THEN
26526 C...W'+/- -> W+/- + Z0
26527             WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
26528      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26529      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26530             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
26531             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
26532           ELSEIF(I.EQ.23) THEN
26533 C...W'+/- -> W+/- + h0
26534             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26535             WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
26536             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26537             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26538           ENDIF
26539           WDTP(I)=FUDGE*WDTP(I)
26540           WDTP(0)=WDTP(0)+WDTP(I)
26541           IF(MDME(IDC,1).GT.0) THEN
26542             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26543             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26544             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26545             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26546           ENDIF
26547   300   CONTINUE
26548  
26549       ELSEIF(KFLA.EQ.37) THEN
26550 C...H+/-:
26551 C        IF(MSTP(49).EQ.0) THEN
26552         SHFS=SH
26553 C        ELSE
26554 C          SHFS=PMAS(37,1)**2
26555 C        ENDIF
26556         FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
26557         DO 310 I=1,MDCY(KC,3)
26558           IDC=I+MDCY(KC,2)-1
26559           IF(MDME(IDC,1).LT.0) GOTO 310
26560           KFC1=PYCOMP(KFDP(IDC,1))
26561           KFC2=PYCOMP(KFDP(IDC,2))
26562           RM1=PMAS(KFC1,1)**2/SH
26563           RM2=PMAS(KFC2,1)**2/SH
26564           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
26565           WID2=1D0
26566           IF(I.LE.4) THEN
26567 C...H+/- -> q + qbar'
26568             RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
26569             RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
26570             WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
26571      &      RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
26572      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26573             IF(KFLR.GT.0) THEN
26574               IF(I.EQ.3) WID2=WIDS(6,2)
26575               IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
26576             ELSE
26577               IF(I.EQ.3) WID2=WIDS(6,3)
26578               IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
26579             ENDIF
26580           ELSEIF(I.LE.8) THEN
26581 C...H+/- -> l+/- + nu
26582             WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
26583      &      (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
26584      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26585             IF(KFLR.GT.0) THEN
26586               IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
26587             ELSE
26588               IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
26589             ENDIF
26590           ELSEIF(I.EQ.9) THEN
26591 C...H+/- -> W+/- + h0.
26592             WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
26593      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26594             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26595             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26596  
26597 CMRENNA++
26598           ELSE
26599 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26600             RM10=RM1*SH/PMR**2
26601             RM20=RM2*SH/PMR**2
26602             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26603             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26604             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26605               WFAC=0D0
26606             ELSE
26607               WFAC=WFAC/WFAC0
26608             ENDIF
26609             WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26610 CMRENNA--
26611             KSGN1=2
26612             IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
26613             KSGN2=2
26614             IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
26615             WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26616           ENDIF
26617           WDTP(I)=FUDGE*WDTP(I)
26618           WDTP(0)=WDTP(0)+WDTP(I)
26619           IF(MDME(IDC,1).GT.0) THEN
26620             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26621             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26622             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26623             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26624           ENDIF
26625   310   CONTINUE
26626  
26627       ELSEIF(KFLA.EQ.41) THEN
26628 C...R:
26629         FAC=(AEM/(12D0*XW))*SHR
26630         DO 320 I=1,MDCY(KC,3)
26631           IDC=I+MDCY(KC,2)-1
26632           IF(MDME(IDC,1).LT.0) GOTO 320
26633           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26634           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26635           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
26636           WID2=1D0
26637           IF(I.LE.6) THEN
26638 C...R -> q + qbar'
26639             FCOF=3D0*RADC
26640           ELSEIF(I.LE.9) THEN
26641 C...R -> l+ + l'-
26642             FCOF=1D0
26643           ENDIF
26644           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26645      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26646           IF(KFLR.GT.0) THEN
26647             IF(I.EQ.4) WID2=WIDS(6,3)
26648             IF(I.EQ.5) WID2=WIDS(7,3)
26649             IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26650             IF(I.EQ.9) WID2=WIDS(17,3)
26651           ELSE
26652             IF(I.EQ.4) WID2=WIDS(6,2)
26653             IF(I.EQ.5) WID2=WIDS(7,2)
26654             IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26655             IF(I.EQ.9) WID2=WIDS(17,2)
26656           ENDIF
26657           WDTP(I)=FUDGE*WDTP(I)
26658           WDTP(0)=WDTP(0)+WDTP(I)
26659           IF(MDME(IDC,1).GT.0) THEN
26660             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26661             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26662             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26663             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26664           ENDIF
26665   320   CONTINUE
26666  
26667       ELSEIF(KFLA.EQ.42) THEN
26668 C...LQ (leptoquark).
26669         FAC=(AEM/4D0)*PARU(151)*SHR
26670         DO 330 I=1,MDCY(KC,3)
26671           IDC=I+MDCY(KC,2)-1
26672           IF(MDME(IDC,1).LT.0) GOTO 330
26673           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26674           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26675           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26676           WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26677           WID2=1D0
26678           ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26679           IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26680           IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26681           ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26682           IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26683           IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26684           WDTP(I)=FUDGE*WDTP(I)
26685           WDTP(0)=WDTP(0)+WDTP(I)
26686           IF(MDME(IDC,1).GT.0) THEN
26687             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26688             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26689             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26690             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26691           ENDIF
26692   330   CONTINUE
26693  
26694 C...UED: kk state width decays : flav: 451 476
26695       ELSEIF(IUED(1).EQ.1.AND.
26696      &       PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26697      &       PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26698          KCLA=PYCOMP(KFLA)
26699 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26700          RMFLAS=PMAS(KCLA,1)
26701          FACSH=SH/PMAS(KCLA,1)**2
26702          ALPHEM=PYALEM(RMFLAS**2)
26703          ALPHS=PYALPS(RMFLAS**2)
26704 
26705 C...uedcor parameters (alpha_s is calculated at mkk scale)
26706 C...alpha_em is calculated at z pole !
26707          ALPHEM=PARU(101)
26708          FACSH=1.
26709          
26710          DO 1070 I=1,MDCY(KCLA,3)
26711           IDC=I+MDCY(KCLA,2)-1
26712 
26713           IF(MDME(IDC,1).LT.0) GOTO 1070
26714           KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26715           KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26716           RM1=PMAS(KFC1,1)**2/SH
26717           RM2=PMAS(KFC2,1)**2/SH
26718           IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26719      &    GOTO 1070
26720           WID2=1D0
26721 
26722 C...N.B. RINV=RUED(1)
26723           RMKK=RUED(1)
26724           RMWKK=PMAS(475,1)
26725           RMZKK=PMAS(474,1)
26726           SW2=PARU(102)
26727           CW2=1.-SW2 
26728           KKCLA=KCLA-KKFLMI+1
26729           IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26730           IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26731           IF(KKCLA.LE.6) THEN
26732 C...q*_S -> q + gamma* (in first time sw21=0)
26733              FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26734 C...Eventually change the following by enabling a choice of open or closed.
26735 C...Only the gamma_kk channel is open.
26736              IF(MOD(I,2).EQ.0)
26737      +            WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26738              WDTP(I)=FACSH*WDTP(I)
26739              WID2=WIDS(473,2)
26740            ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26741 C...q*_D -> q + Z*/W*
26742               FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26743               GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26744               IF(I.EQ.1)THEN
26745 C...q*_D -> q + Z*
26746                  WDTP(I)=0.5*GAMMAW
26747                  WID2=WIDS(474,2)                 
26748               ELSEIF(I.EQ.2)THEN
26749 C...q*_D -> q + W*
26750                  WDTP(I)=GAMMAW
26751                  WID2=WIDS(475,2)                 
26752               ENDIF
26753               WDTP(I)=FACSH*WDTP(I)
26754 C...q*_D -> q + gamma* is closed
26755            ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26756 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26757               FAC=ALPHEM/4.*RMFLAS/CW2/8.
26758               RMGAKK=PMAS(473,1)
26759               WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26760      +                FKAC1(RMGAKK,RMFLAS)**2
26761               WDTP(I)=FACSH*WDTP(I)
26762               WID2=WIDS(473,2)
26763            ELSEIF(KKCLA.EQ.22)THEN
26764               RMQST=PMAS(KKPART,1)
26765               WID2=WIDS(KKPART,2)
26766 C...g* -> q*_S/q*_D + q
26767               FAC=10.*ALPHS/12.*RMFLAS
26768               WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26769               WDTP(I)=FACSH*WDTP(I)
26770            ELSEIF(KKCLA.EQ.23)THEN
26771 C...gamma* decays to graviton + gamma : initial value is used
26772              ICHI=IUED(4)/2
26773              WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26774      &            *CHIDEL(ICHI)
26775            ELSEIF(KKCLA.EQ.24)THEN 
26776 C...Z* -> l*_S + l is closed
26777 C...  Z* -> l*_D + l
26778              IF(I.LE.3)GOTO 1070
26779 c...  After closing the channels for a Z* decaying into positively charged 
26780 C...  KK lepton singlets, close the channels for a Z* decaying into negatively 
26781 C...  charged KK lepton singlets + positively charged SM particles
26782              IF(I.GE.10.AND.I.LE.12)GOTO 1070
26783              FAC=3./2.*ALPHEM/24./SW2*RMZKK
26784              RMLST=PMAS(KKPART,1)
26785              WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26786              WDTP(I)=FACSH*WDTP(I)
26787              WID2=WIDS(KKPART,2)                 
26788            ELSEIF(KKCLA.EQ.25)THEN 
26789 C...W* -> l*_D lbar
26790              FAC=3.*ALPHEM/12./SW2*RMWKK
26791              RMLST=PMAS(KKPART,1)
26792              WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26793              WDTP(I)=FACSH*WDTP(I)
26794              WID2=WIDS(KKPART,2)                 
26795            ENDIF
26796           WDTP(0)=WDTP(0)+WDTP(I)
26797           IF(MDME(IDC,1).GT.0) THEN
26798             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26799             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26800             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26801             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26802           ENDIF
26803  1070   CONTINUE
26804         IUEDPR(KKCLA)=1
26805 
26806       ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26807 C...Techni-pi0 and techni-pi0':
26808         FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26809         DO 340 I=1,MDCY(KC,3)
26810           IDC=I+MDCY(KC,2)-1
26811           IF(MDME(IDC,1).LT.0) GOTO 340
26812           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26813           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26814           RM1=PM1**2/SH
26815           RM2=PM2**2/SH
26816           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26817           WID2=1D0
26818 C...pi_tc -> g + g
26819           IF(I.EQ.8) THEN
26820             FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26821      &      /(8D0*PARU(1))*SH*SHR
26822             IF(KFLA.EQ.KTECHN+111) THEN
26823               FACP=FACP*RTCM(9)
26824             ELSE
26825               FACP=FACP*RTCM(10)
26826             ENDIF
26827             WDTP(I)=FACP
26828           ELSE
26829 C...pi_tc -> f + fbar.
26830             FCOF=1D0
26831             IKA=IABS(KFDP(IDC,1))
26832             IF(IKA.LT.10) FCOF=3D0*RADC
26833             HM1=PM1
26834             HM2=PM2
26835             IF(IKA.GE.4.AND.IKA.LE.6) THEN
26836                FCOF=FCOF*RTCM(1+IKA)**2
26837                HM1=PYMRUN(KFDP(IDC,1),SH)
26838                HM2=PYMRUN(KFDP(IDC,2),SH)
26839             ELSEIF(IKA.EQ.15) THEN
26840                FCOF=FCOF*RTCM(8)**2
26841             ENDIF
26842             WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26843      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26844           ENDIF
26845           WDTP(I)=FUDGE*WDTP(I)
26846           WDTP(0)=WDTP(0)+WDTP(I)
26847           IF(MDME(IDC,1).GT.0) THEN
26848             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26849             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26850             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26851             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26852           ENDIF
26853   340   CONTINUE
26854  
26855       ELSEIF(KFLA.EQ.KTECHN+211) THEN
26856 C...pi+_tc
26857         FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26858         DO 350 I=1,MDCY(KC,3)
26859           IDC=I+MDCY(KC,2)-1
26860           IF(MDME(IDC,1).LT.0) GOTO 350
26861           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26862           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26863           PM3=0D0
26864           IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26865           RM1=PM1**2/SH
26866           RM2=PM2**2/SH
26867           RM3=PM3**2/SH
26868           IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26869           WID2=1D0
26870 C...pi_tc -> f + f'.
26871           FCOF=1D0
26872           IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26873 C...pi_tc+ -> W b b~
26874           IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26875             FCOF=3D0*RADC
26876             XMT2=PMAS(6,1)**2/SH
26877             FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26878             KFC3=PYCOMP(KFDP(IDC,3))
26879             CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26880             CHECK = SQRT(RM1)
26881             T0 = (1D0-CHECK**2)*
26882      &      (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26883      &      (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26884             T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26885      &      -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26886             T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26887             WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26888      &      +T3*LOG(CHECK))
26889             IF(KFLR.GT.0) THEN
26890                WID2=WIDS(24,2)
26891             ELSE
26892                WID2=WIDS(24,3)
26893             ENDIF
26894           ELSE
26895             FCOF=1D0
26896             IKA=IABS(KFDP(IDC,1))
26897             IF(IKA.LT.10) FCOF=3D0*RADC
26898             HM1=PM1
26899             HM2=PM2
26900             IF(I.GE.1.AND.I.LE.5) THEN
26901               IF(I.LE.2) THEN
26902                 FCOF=FCOF*RTCM(5)**2
26903               ELSEIF(I.LE.4) THEN
26904                 FCOF=FCOF*RTCM(6)**2
26905               ELSEIF(I.EQ.5) THEN
26906                 FCOF=FCOF*RTCM(7)**2
26907               ENDIF
26908               HM1=PYMRUN(KFDP(IDC,1),SH)
26909               HM2=PYMRUN(KFDP(IDC,2),SH)
26910             ELSEIF(I.EQ.8) THEN
26911               FCOF=FCOF*RTCM(8)**2
26912             ENDIF
26913             WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26914      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26915           ENDIF
26916           WDTP(I)=FUDGE*WDTP(I)
26917           WDTP(0)=WDTP(0)+WDTP(I)
26918           IF(MDME(IDC,1).GT.0) THEN
26919             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26920             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26921             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26922             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26923           ENDIF
26924   350     CONTINUE
26925  
26926       ELSEIF(KFLA.EQ.KTECHN+331) THEN
26927 C...Techni-eta.
26928         FAC=(SH/PARP(46)**2)*SHR
26929         DO 360 I=1,MDCY(KC,3)
26930           IDC=I+MDCY(KC,2)-1
26931           IF(MDME(IDC,1).LT.0) GOTO 360
26932           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26933           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26934           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26935           WID2=1D0
26936           IF(I.LE.2) THEN
26937             WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26938             IF(I.EQ.2) WID2=WIDS(6,1)
26939           ELSE
26940             WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26941           ENDIF
26942           WDTP(I)=FUDGE*WDTP(I)
26943           WDTP(0)=WDTP(0)+WDTP(I)
26944           IF(MDME(IDC,1).GT.0) THEN
26945             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26946             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26947             WDTE(I,0)=WDTE(I,MDME(IDC,1))
26948             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26949           ENDIF
26950   360   CONTINUE
26951  
26952       ELSEIF(KFLA.EQ.KTECHN+113) THEN
26953 C...Techni-rho0:
26954         ALPRHT=2.16D0*(3D0/ITCM(1))
26955         FAC=(ALPRHT/12D0)*SHR
26956         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26957         SQMZ=PMAS(23,1)**2
26958         SQMW=PMAS(24,1)**2
26959         SHP=SH
26960         CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26961         GMMZ=SHR*WDTPP(0)
26962         XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26963         BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26964         BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26965         DO 370 I=1,MDCY(KC,3)
26966           IDC=I+MDCY(KC,2)-1
26967           IF(MDME(IDC,1).LT.0) GOTO 370
26968           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26969           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26970           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26971           WID2=1D0
26972           IF(I.EQ.1) THEN
26973 C...rho_tc0 -> W+ + W-.
26974 C... Multiplied by  2 for W^+_T W^-_L + W^+_L W^-_T  
26975             WDTP(I)=FAC*RTCM(3)**4*
26976      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26977      &      2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26978      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26979      &      RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26980             WID2=WIDS(24,1)
26981           ELSEIF(I.EQ.2) THEN
26982 C...rho_tc0 -> W+ + pi_tc-.
26983 C... Multiplied by  2 for pi_T^+ W^-_T + pi_T^- W^+_T  
26984             WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26985      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26986      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26987      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26988      &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26989             WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26990           ELSEIF(I.EQ.3) THEN
26991 C...rho_tc0 -> pi_tc+ + W-.
26992             WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26993      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26994      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26995      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26996      &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26997             WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26998           ELSEIF(I.EQ.4) THEN
26999 C...rho_tc0 -> pi_tc+ + pi_tc-.
27000             WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27001      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27002             WID2=WIDS(PYCOMP(KTECHN+211),1)
27003           ELSEIF(I.EQ.5) THEN
27004 C...rho_tc0 -> gamma + pi_tc0
27005             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27006      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27007      &      SHR**3
27008             WID2=WIDS(PYCOMP(KTECHN+111),2)
27009           ELSEIF(I.EQ.6) THEN
27010 C...rho_tc0 -> gamma + pi_tc0'
27011             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27012      &      (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
27013             WID2=WIDS(PYCOMP(KTECHN+221),2)
27014           ELSEIF(I.EQ.7) THEN
27015 C...rho_tc0 -> Z0 + pi_tc0
27016             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27017      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27018      &      XW/XW1*SHR**3
27019             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27020           ELSEIF(I.EQ.8) THEN
27021 C...rho_tc0 -> Z0 + pi_tc0'
27022             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27023      &      (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27024      &      XW/XW1*SHR**3
27025             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27026           ELSEIF(I.EQ.9) THEN
27027 C...rho_tc0 -> gamma + Z0
27028             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27029      &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27030             WID2=WIDS(23,2)
27031           ELSEIF(I.EQ.10) THEN
27032 C...rho_tc0 -> Z0 + Z0
27033             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27034      &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
27035      &      SHR**3
27036             WID2=WIDS(23,1)
27037           ELSE
27038 C...rho_tc0 -> f + fbar.
27039             WID2=1D0
27040             IF(I.LE.18) THEN
27041               IA=I-10
27042               FCOF=3D0*RADC
27043               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27044             ELSE
27045               IA=I-6
27046               FCOF=1D0
27047               IF(IA.GE.17) WID2=WIDS(IA,1)
27048             ENDIF
27049             EI=KCHG(IA,1)/3D0
27050             AI=SIGN(1D0,EI+0.1D0)
27051             VI=AI-4D0*EI*XWV
27052             VALI=0.5D0*(VI+AI)
27053             VARI=0.5D0*(VI-AI)
27054             WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27055      &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27056      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27057      &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27058           ENDIF
27059           WDTP(I)=FUDGE*WDTP(I)
27060           WDTP(0)=WDTP(0)+WDTP(I)
27061           IF(MDME(IDC,1).GT.0) THEN
27062             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27063             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27064             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27065             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27066           ENDIF
27067   370   CONTINUE
27068  
27069       ELSEIF(KFLA.EQ.KTECHN+213) THEN
27070 C...Techni-rho+/-:
27071         ALPRHT=2.16D0*(3D0/ITCM(1))
27072         FAC=(ALPRHT/12D0)*SHR
27073         SQMZ=PMAS(23,1)**2
27074         SQMW=PMAS(24,1)**2
27075         SHP=SH
27076         CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27077         GMMW=SHR*WDTPP(0)
27078         FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27079      &  (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27080         DO 380 I=1,MDCY(KC,3)
27081           IDC=I+MDCY(KC,2)-1
27082           IF(MDME(IDC,1).LT.0) GOTO 380
27083           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27084           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27085           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
27086           WID2=1D0
27087           PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27088 c            WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27089 c     &      /3D0*SHR**3
27090           IF(I.EQ.1) THEN
27091 C...rho_tc+ -> W+ + Z0.
27092 C......Goldstone
27093             WDTP(I)=FAC*RTCM(3)**4*
27094      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27095             VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
27096             AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
27097 C......W_L Z_T
27098             WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
27099      &      /3D0*SHR**3
27100             VA2=0D0
27101             AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
27102 C......W_T Z_L
27103             WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27104      &      /3D0*SHR**3
27105             IF(KFLR.GT.0) THEN
27106               WID2=WIDS(24,2)*WIDS(23,2)
27107             ELSE
27108               WID2=WIDS(24,3)*WIDS(23,2)
27109             ENDIF
27110           ELSEIF(I.EQ.2) THEN
27111 C...rho_tc+ -> W+ + pi_tc0.
27112             WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27113      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27114      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27115      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
27116      &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27117             IF(KFLR.GT.0) THEN
27118               WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
27119             ELSE
27120               WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
27121             ENDIF
27122           ELSEIF(I.EQ.3) THEN
27123 C...rho_tc+ -> pi_tc+ + Z0.
27124             WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27125      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27126      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27127      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
27128      &      (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
27129      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27130      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27131      &      SHR**3*XW/XW1
27132             IF(KFLR.GT.0) THEN
27133               WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
27134             ELSE
27135               WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
27136             ENDIF
27137           ELSEIF(I.EQ.4) THEN
27138 C...rho_tc+ -> pi_tc+ + pi_tc0.
27139             WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27140      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27141             IF(KFLR.GT.0) THEN
27142               WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
27143             ELSE
27144               WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
27145             ENDIF
27146           ELSEIF(I.EQ.5) THEN
27147 C...rho_tc+ -> pi_tc+ + gamma
27148             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27149      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27150      &      SHR**3
27151             IF(KFLR.GT.0) THEN
27152               WID2=WIDS(PYCOMP(KTECHN+211),2)
27153             ELSE
27154               WID2=WIDS(PYCOMP(KTECHN+211),3)
27155             ENDIF
27156           ELSEIF(I.EQ.6) THEN
27157 C...rho_tc+ -> W+ + pi_tc0'
27158             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27159      &      (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
27160             IF(KFLR.GT.0) THEN
27161               WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
27162             ELSE
27163               WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
27164             ENDIF
27165           ELSEIF(I.EQ.7) THEN
27166 C...rho_tc+ -> W+ + gamma
27167             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27168      &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27169             IF(KFLR.GT.0) THEN
27170               WID2=WIDS(24,2)
27171             ELSE
27172               WID2=WIDS(24,3)
27173             ENDIF
27174           ELSE
27175 C...rho_tc+ -> f + fbar'.
27176             IA=I-7
27177             WID2=1D0
27178             IF(IA.LE.16) THEN
27179               FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27180               IF(KFLR.GT.0) THEN
27181                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27182                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27183                 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27184               ELSE
27185                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27186                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27187                 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27188               ENDIF
27189             ELSE
27190               FCOF=1D0
27191               IF(KFLR.GT.0) THEN
27192                 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27193               ELSE
27194                 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27195               ENDIF
27196             ENDIF
27197             WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27198      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27199           ENDIF
27200           WDTP(I)=FUDGE*WDTP(I)
27201           WDTP(0)=WDTP(0)+WDTP(I)
27202           IF(MDME(IDC,1).GT.0) THEN
27203             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27204             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27205             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27206             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27207           ENDIF
27208   380   CONTINUE
27209  
27210       ELSEIF(KFLA.EQ.KTECHN+223) THEN
27211 C...Techni-omega:
27212         ALPRHT=2.16D0*(3D0/ITCM(1))
27213         FAC=(ALPRHT/12D0)*SHR
27214         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
27215         SQMZ=PMAS(23,1)**2
27216         SHP=SH
27217         CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27218         GMMZ=SHR*WDTPP(0)
27219         BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27220         BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27221         DO 390 I=1,MDCY(KC,3)
27222           IDC=I+MDCY(KC,2)-1
27223           IF(MDME(IDC,1).LT.0) GOTO 390
27224           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27225           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27226           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
27227           WID2=1D0
27228           IF(I.EQ.1) THEN
27229 C...omega_tc0 -> gamma + pi_tc0.
27230             WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
27231      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
27232             WID2=WIDS(PYCOMP(KTECHN+111),2)
27233           ELSEIF(I.EQ.2) THEN
27234 C...omega_tc0 -> Z0 + pi_tc0
27235             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27236      &      (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27237      &      XW/XW1*SHR**3
27238             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27239           ELSEIF(I.EQ.3) THEN
27240 C...omega_tc0 -> gamma + pi_tc0'
27241             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27242      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27243      &      SHR**3
27244             WID2=WIDS(PYCOMP(KTECHN+221),2)
27245           ELSEIF(I.EQ.4) THEN
27246 C...omega_tc0 -> Z0 + pi_tc0'
27247             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27248      &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27249      &      XW/XW1*SHR**3
27250             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27251           ELSEIF(I.EQ.5) THEN
27252 C...omega_tc0 -> W+ + pi_tc-
27253             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27254      &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27255      &      FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27256      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27257             WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27258           ELSEIF(I.EQ.6) THEN
27259 C...omega_tc0 -> pi_tc+ + W-
27260             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27261      &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27262      &      FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27263      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27264             WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27265           ELSEIF(I.EQ.7) THEN
27266 C...omega_tc0 -> W+ + W-.
27267 C... Multiplied by  2 for W^+_T W^-_L + W^+_L W^-_T  
27268             WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
27269      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27270      &      2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27271      &      RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
27272             WID2=WIDS(24,1)
27273           ELSEIF(I.EQ.8) THEN
27274 C...omega_tc0 -> pi_tc+ + pi_tc-.
27275             WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
27276      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27277             WID2=WIDS(PYCOMP(KTECHN+211),1)
27278 C...omega_tc0 -> gamma + Z0
27279           ELSEIF(I.EQ.9) THEN
27280             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27281      &      RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27282             WID2=WIDS(23,2)
27283 C...omega_tc0 -> Z0 + Z0
27284           ELSEIF(I.EQ.10) THEN
27285             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27286      &      RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
27287      &      /24D0/RTCM(12)**2*SHR**3
27288             WID2=WIDS(23,1)
27289           ELSE
27290 C...omega_tc0 -> f + fbar.
27291             WID2=1D0
27292             IF(I.LE.18) THEN
27293               IA=I-10
27294               FCOF=3D0*RADC
27295               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27296             ELSE
27297               IA=I-8
27298               FCOF=1D0
27299               IF(IA.GE.17) WID2=WIDS(IA,1)
27300             ENDIF
27301             EI=KCHG(IA,1)/3D0
27302             AI=SIGN(1D0,EI+0.1D0)
27303             VI=AI-4D0*EI*XWV
27304             VALI=-0.5D0*(VI+AI)
27305             VARI=-0.5D0*(VI-AI)
27306             WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27307      &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27308      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27309      &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27310           ENDIF
27311           WDTP(I)=FUDGE*WDTP(I)
27312           WDTP(0)=WDTP(0)+WDTP(I)
27313           IF(MDME(IDC,1).GT.0) THEN
27314             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27315             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27316             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27317             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27318           ENDIF
27319   390   CONTINUE
27320  
27321 C.....V8 -> quark anti-quark
27322       ELSEIF(KFLA.EQ.KTECHN+100021) THEN
27323         FAC=AS/6D0*SHR
27324         TANT3=RTCM(21)
27325         IF(ITCM(2).EQ.0) THEN
27326           IMDL=1
27327         ELSEIF(ITCM(2).EQ.1) THEN
27328           IMDL=2
27329         ENDIF
27330         DO 400 I=1,MDCY(KC,3)
27331           IDC=I+MDCY(KC,2)-1
27332           IF(MDME(IDC,1).LT.0) GOTO 400
27333           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27334           RM1=PM1**2/SH
27335           IF(RM1.GT.0.25D0) GOTO 400
27336           WID2=1D0
27337           IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27338             FMIX=1D0/TANT3**2
27339           ELSE
27340             FMIX=TANT3**2
27341           ENDIF
27342           WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
27343           IF(I.EQ.6) WID2=WIDS(6,1)
27344           WDTP(I)=FUDGE*WDTP(I)
27345           WDTP(0)=WDTP(0)+WDTP(I)
27346           IF(MDME(IDC,1).GT.0) THEN
27347             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27348             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27349             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27350             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27351           ENDIF
27352   400   CONTINUE
27353  
27354       ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
27355         FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
27356         CLEBF=0D0
27357         DO 410 I=1,MDCY(KC,3)
27358           IDC=I+MDCY(KC,2)-1
27359           IF(MDME(IDC,1).LT.0) GOTO 410
27360           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27361           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27362           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
27363           WID2=1D0
27364 C...pi_tc -> g + g
27365           IF(I.EQ.7) THEN
27366             IF(KFLA.EQ.KTECHN+100111) THEN
27367               CLEBG=4D0/3D0
27368             ELSE
27369               CLEBG=5D0/3D0
27370             ENDIF
27371             FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
27372      &      /(2D0*PARU(1))*SH*SHR*CLEBG
27373             WDTP(I)=FACP
27374           ELSE
27375 C...pi_tc -> f + fbar.
27376             IF(I.EQ.6) WID2=WIDS(6,1)
27377             FCOF=1D0
27378             IKA=IABS(KFDP(IDC,1))
27379             IF(IKA.LT.10) FCOF=3D0*RADC
27380             HM1=PYMRUN(KFDP(IDC,1),SH)
27381             WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
27382      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27383           ENDIF
27384           WDTP(I)=FUDGE*WDTP(I)
27385           WDTP(0)=WDTP(0)+WDTP(I)
27386           IF(MDME(IDC,1).GT.0) THEN
27387             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27388             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27389             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27390             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27391           ENDIF
27392   410   CONTINUE
27393  
27394       ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
27395         FAC=AS/6D0*SHR
27396         ALPRHT=2.16D0*(3D0/ITCM(1))
27397         TANT3=RTCM(21)
27398         SIN2T=2D0*TANT3/(TANT3**2+1D0)
27399         SINT3=TANT3/SQRT(TANT3**2+1D0)
27400         CSXPP=RTCM(22)
27401         RM82=RTCM(27)**2
27402         X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
27403      &  RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
27404         X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
27405      &  RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
27406         X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
27407      &  SINT3**2)*2D0
27408         X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
27409      &  SINT3**2)*2D0
27410         CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
27411  
27412         IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
27413         GMV8=SHR*WDTPP(0)
27414         RMV8=PMAS(PYCOMP(KTECHN+100021),1)
27415         FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
27416         FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
27417         IF(ITCM(2).EQ.0) THEN
27418           IMDL=1
27419         ELSE
27420           IMDL=2
27421         ENDIF
27422         DO 420 I=1,MDCY(KC,3)
27423           IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
27424      &    KFLA.EQ.KTECHN+300113)) GOTO 420
27425           IDC=I+MDCY(KC,2)-1
27426           IF(MDME(IDC,1).LT.0) GOTO 420
27427           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27428           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27429           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
27430           WID2=1D0
27431           IF(I.LE.6) THEN
27432             IF(I.EQ.6) WID2=WIDS(6,1)
27433             XIG=1D0
27434             IF(KFLA.EQ.KTECHN+200113) THEN
27435               XIG=0D0
27436               XIJ=X12
27437             ELSEIF(KFLA.EQ.KTECHN+300113) THEN
27438               XIG=0D0
27439               XIJ=X21
27440             ELSEIF(KFLA.EQ.KTECHN+100113) THEN
27441               XIJ=X11
27442             ELSE
27443               XIJ=X22
27444             ENDIF
27445             IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27446               FMIX=1D0/TANT3/SIN2T
27447             ELSE
27448               FMIX=-TANT3/SIN2T
27449             ENDIF
27450             XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
27451             WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
27452           ELSEIF(I.EQ.7) THEN
27453             WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
27454           ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
27455             PSH=SHR*(1D0-RM1)/2D0
27456             WDTP(I)=AS/9D0*PSH**3/RM82
27457             IF(I.EQ.8) THEN
27458               WDTP(I)=2D0*WDTP(I)*CSXPP**2
27459               WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27460             ELSE
27461               WDTP(I)=5D0*WDTP(I)
27462               WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27463             ENDIF
27464           ENDIF
27465           WDTP(I)=FUDGE*WDTP(I)
27466           WDTP(0)=WDTP(0)+WDTP(I)
27467           IF(MDME(IDC,1).GT.0) THEN
27468             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27469             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27470             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27471             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27472           ENDIF
27473   420   CONTINUE
27474  
27475       ELSEIF(KFLA.EQ.KEXCIT+1) THEN
27476 C...d* excited quark.
27477         FAC=(SH/RTCM(41)**2)*SHR
27478         DO 430 I=1,MDCY(KC,3)
27479           IDC=I+MDCY(KC,2)-1
27480           IF(MDME(IDC,1).LT.0) GOTO 430
27481           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27482           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27483           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
27484           WID2=1D0
27485           IF(I.EQ.1) THEN
27486 C...d* -> g + d.
27487             WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27488             WID2=1D0
27489           ELSEIF(I.EQ.2) THEN
27490 C...d* -> gamma + d.
27491             QF=-RTCM(43)/2D0+RTCM(44)/6D0
27492             WDTP(I)=FAC*AEM*QF**2/4D0
27493             WID2=1D0
27494           ELSEIF(I.EQ.3) THEN
27495 C...d* -> Z0 + d.
27496             QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27497             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27498      &      (1D0-RM1)**2*(2D0+RM1)
27499             WID2=WIDS(23,2)
27500           ELSEIF(I.EQ.4) THEN
27501 C...d* -> W- + u.
27502             WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27503      &      (1D0-RM1)**2*(2D0+RM1)
27504             IF(KFLR.GT.0) WID2=WIDS(24,3)
27505             IF(KFLR.LT.0) WID2=WIDS(24,2)
27506           ENDIF
27507           WDTP(I)=FUDGE*WDTP(I)
27508           WDTP(0)=WDTP(0)+WDTP(I)
27509           IF(MDME(IDC,1).GT.0) THEN
27510             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27511             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27512             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27513             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27514           ENDIF
27515   430   CONTINUE
27516  
27517       ELSEIF(KFLA.EQ.KEXCIT+2) THEN
27518 C...u* excited quark.
27519         FAC=(SH/RTCM(41)**2)*SHR
27520         DO 440 I=1,MDCY(KC,3)
27521           IDC=I+MDCY(KC,2)-1
27522           IF(MDME(IDC,1).LT.0) GOTO 440
27523           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27524           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27525           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
27526           WID2=1D0
27527           IF(I.EQ.1) THEN
27528 C...u* -> g + u.
27529             WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27530             WID2=1D0
27531           ELSEIF(I.EQ.2) THEN
27532 C...u* -> gamma + u.
27533             QF=RTCM(43)/2D0+RTCM(44)/6D0
27534             WDTP(I)=FAC*AEM*QF**2/4D0
27535             WID2=1D0
27536           ELSEIF(I.EQ.3) THEN
27537 C...u* -> Z0 + u.
27538             QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27539             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27540      &      (1D0-RM1)**2*(2D0+RM1)
27541             WID2=WIDS(23,2)
27542           ELSEIF(I.EQ.4) THEN
27543 C...u* -> W+ + d.
27544             WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27545      &      (1D0-RM1)**2*(2D0+RM1)
27546             IF(KFLR.GT.0) WID2=WIDS(24,2)
27547             IF(KFLR.LT.0) WID2=WIDS(24,3)
27548           ENDIF
27549           WDTP(I)=FUDGE*WDTP(I)
27550           WDTP(0)=WDTP(0)+WDTP(I)
27551           IF(MDME(IDC,1).GT.0) THEN
27552             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27553             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27554             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27555             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27556           ENDIF
27557   440   CONTINUE
27558  
27559       ELSEIF(KFLA.EQ.KEXCIT+11) THEN
27560 C...e* excited lepton.
27561         FAC=(SH/RTCM(41)**2)*SHR
27562         DO 450 I=1,MDCY(KC,3)
27563           IDC=I+MDCY(KC,2)-1
27564           IF(MDME(IDC,1).LT.0) GOTO 450
27565           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27566           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27567           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
27568           WID2=1D0
27569           IF(I.EQ.1) THEN
27570 C...e* -> gamma + e.
27571             QF=-RTCM(43)/2D0-RTCM(44)/2D0
27572             WDTP(I)=FAC*AEM*QF**2/4D0
27573             WID2=1D0
27574           ELSEIF(I.EQ.2) THEN
27575 C...e* -> Z0 + e.
27576             QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27577             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27578      &      (1D0-RM1)**2*(2D0+RM1)
27579             WID2=WIDS(23,2)
27580           ELSEIF(I.EQ.3) THEN
27581 C...e* -> W- + nu.
27582             WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27583      &      (1D0-RM1)**2*(2D0+RM1)
27584             IF(KFLR.GT.0) WID2=WIDS(24,3)
27585             IF(KFLR.LT.0) WID2=WIDS(24,2)
27586           ENDIF
27587           WDTP(I)=FUDGE*WDTP(I)
27588           WDTP(0)=WDTP(0)+WDTP(I)
27589           IF(MDME(IDC,1).GT.0) THEN
27590             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27591             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27592             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27593             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27594           ENDIF
27595   450   CONTINUE
27596  
27597       ELSEIF(KFLA.EQ.KEXCIT+12) THEN
27598 C...nu*_e excited neutrino.
27599         FAC=(SH/RTCM(41)**2)*SHR
27600         DO 460 I=1,MDCY(KC,3)
27601           IDC=I+MDCY(KC,2)-1
27602           IF(MDME(IDC,1).LT.0) GOTO 460
27603           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27604           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27605           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
27606           WID2=1D0
27607           IF(I.EQ.1) THEN
27608 C...nu*_e -> Z0 + nu*_e.
27609             QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27610             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27611      &      (1D0-RM1)**2*(2D0+RM1)
27612             WID2=WIDS(23,2)
27613           ELSEIF(I.EQ.2) THEN
27614 C...nu*_e -> W+ + e.
27615             WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27616      &      (1D0-RM1)**2*(2D0+RM1)
27617             IF(KFLR.GT.0) WID2=WIDS(24,2)
27618             IF(KFLR.LT.0) WID2=WIDS(24,3)
27619           ENDIF
27620           WDTP(I)=FUDGE*WDTP(I)
27621           WDTP(0)=WDTP(0)+WDTP(I)
27622           IF(MDME(IDC,1).GT.0) THEN
27623             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27624             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27625             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27626             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27627           ENDIF
27628   460   CONTINUE
27629  
27630       ELSEIF(KFLA.EQ.KDIMEN+39) THEN
27631 C...G* (graviton resonance):
27632         FAC=(PARP(50)**2/PARU(1))*SHR
27633         DO 470 I=1,MDCY(KC,3)
27634           IDC=I+MDCY(KC,2)-1
27635           IF(MDME(IDC,1).LT.0) GOTO 470
27636           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27637           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27638           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
27639           WID2=1D0
27640           IF(I.LE.8) THEN
27641 C...G* -> q + qbar
27642             FCOF=3D0*RADC
27643             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27644      &      PYHFTH(SH,SH*RM1,1D0)
27645             WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27646      &      (1D0+8D0*RM1/3D0)/320D0
27647             IF(I.EQ.6) WID2=WIDS(6,1)
27648             IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27649           ELSEIF(I.LE.16) THEN
27650 C...G* -> l+ + l-, nu + nubar
27651             FCOF=1D0
27652             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27653      &      (1D0+8D0*RM1/3D0)/320D0
27654             IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27655           ELSEIF(I.EQ.17) THEN
27656 C...G* -> g + g.
27657             WDTP(I)=FAC/20D0
27658           ELSEIF(I.EQ.18) THEN
27659 C...G* -> gamma + gamma.
27660             WDTP(I)=FAC/160D0
27661           ELSEIF(I.EQ.19) THEN
27662 C...G* -> Z0 + Z0.
27663             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27664      &      14D0*RM1/3D0+4D0*RM1**2)/160D0
27665             WID2=WIDS(23,1)
27666           ELSEIF(I.EQ.20) THEN
27667 C...G* -> W+ + W-.
27668             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27669      &      14D0*RM1/3D0+4D0*RM1**2)/80D0
27670             WID2=WIDS(24,1)
27671           ENDIF
27672           WDTP(I)=FUDGE*WDTP(I)
27673           WDTP(0)=WDTP(0)+WDTP(I)
27674           IF(MDME(IDC,1).GT.0) THEN
27675             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27676             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27677             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27678             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27679           ENDIF
27680   470   CONTINUE
27681  
27682       ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27683 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27684         PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27685         FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27686         DO 480 I=1,MDCY(KC,3)
27687           IDC=I+MDCY(KC,2)-1
27688           IF(MDME(IDC,1).LT.0) GOTO 480
27689           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27690           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27691           PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27692           IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27693           WID2=1D0
27694           IF(I.LE.9) THEN
27695 C...nu_lR -> l- qbar q'
27696             FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27697             IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27698           ELSEIF(I.LE.18) THEN
27699 C...nu_lR -> l+ q qbar'
27700             FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27701             IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27702           ELSE
27703 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27704             FCOF=1D0
27705             WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27706           ENDIF
27707           X=(PM1+PM2+PM3)/SHR
27708           FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27709           Y=(SHR/PMWR)**2
27710           FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27711           WDTP(I)=FAC*FCOF*FX*FY
27712           WDTP(I)=FUDGE*WDTP(I)
27713           WDTP(0)=WDTP(0)+WDTP(I)
27714           IF(MDME(IDC,1).GT.0) THEN
27715             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27716             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27717             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27718             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27719           ENDIF
27720   480   CONTINUE
27721  
27722       ELSEIF(KFLA.EQ.9900023) THEN
27723 C...Z_R0:
27724         FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27725         DO 490 I=1,MDCY(KC,3)
27726           IDC=I+MDCY(KC,2)-1
27727           IF(MDME(IDC,1).LT.0) GOTO 490
27728           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27729           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27730           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27731           WID2=1D0
27732           SYMMET=1D0
27733           IF(I.LE.6) THEN
27734 C...Z_R0 -> q + qbar
27735             EF=KCHG(I,1)/3D0
27736             AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27737             VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27738             FCOF=3D0*RADC
27739             IF(I.EQ.6) WID2=WIDS(6,1)
27740           ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27741 C...Z_R0 -> l+ + l-
27742             AF=-(1D0-2D0*XW)
27743             VF=-1D0+4D0*XW
27744             FCOF=1D0
27745           ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27746 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27747             AF=-2D0*XW
27748             VF=0D0
27749             FCOF=1D0
27750             SYMMET=0.5D0
27751           ELSEIF(I.LE.15) THEN
27752 C...Z0 -> nu_R + nu_R, assumed Majorana.
27753             AF=2D0*XW1
27754             VF=0D0
27755             FCOF=1D0
27756             WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27757             SYMMET=0.5D0
27758           ENDIF
27759           WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27760      &    SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27761           WDTP(I)=FUDGE*WDTP(I)
27762           WDTP(0)=WDTP(0)+WDTP(I)
27763           IF(MDME(IDC,1).GT.0) THEN
27764             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27765             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27766             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27767             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27768           ENDIF
27769   490   CONTINUE
27770  
27771       ELSEIF(KFLA.EQ.9900024) THEN
27772 C...W_R+/-:
27773         FAC=(AEM/(24D0*XW))*SHR
27774         DO 500 I=1,MDCY(KC,3)
27775           IDC=I+MDCY(KC,2)-1
27776           IF(MDME(IDC,1).LT.0) GOTO 500
27777           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27778           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27779           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27780           WID2=1D0
27781           IF(I.LE.9) THEN
27782 C...W_R+/- -> q + qbar'
27783             FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27784             IF(KFLR.GT.0) THEN
27785               IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27786             ELSE
27787               IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27788             ENDIF
27789           ELSEIF(I.LE.12) THEN
27790 C...W_R+/- -> l+/- + nu_R
27791             FCOF=1D0
27792           ENDIF
27793           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27794      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27795           WDTP(I)=FUDGE*WDTP(I)
27796           WDTP(0)=WDTP(0)+WDTP(I)
27797           IF(MDME(IDC,1).GT.0) THEN
27798             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27799             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27800             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27801             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27802           ENDIF
27803   500  CONTINUE
27804  
27805       ELSEIF(KFLA.EQ.9900041) THEN
27806 C...H_L++/--:
27807         FAC=(1D0/(8D0*PARU(1)))*SHR
27808         DO 510 I=1,MDCY(KC,3)
27809           IDC=I+MDCY(KC,2)-1
27810           IF(MDME(IDC,1).LT.0) GOTO 510
27811           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27812           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27813           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27814           WID2=1D0
27815           IF(I.LE.6) THEN
27816 C...H_L++/-- -> l+/- + l'+/-
27817             FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27818      &      (IABS(KFDP(IDC,2))-9)/2)**2
27819             IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27820           ELSEIF(I.EQ.7) THEN
27821 C...H_L++/-- -> W_L+/- + W_L+/-
27822             FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27823      &      (3D0*RM1+0.25D0/RM1-1D0)
27824             WID2=WIDS(24,4+(1-KFLS)/2)
27825           ENDIF
27826           WDTP(I)=FAC*FCOF*
27827      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27828           WDTP(I)=FUDGE*WDTP(I)
27829           WDTP(0)=WDTP(0)+WDTP(I)
27830           IF(MDME(IDC,1).GT.0) THEN
27831             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27832             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27833             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27834             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27835           ENDIF
27836   510   CONTINUE
27837  
27838       ELSEIF(KFLA.EQ.9900042) THEN
27839 C...H_R++/--:
27840         FAC=(1D0/(8D0*PARU(1)))*SHR
27841         DO 520 I=1,MDCY(KC,3)
27842           IDC=I+MDCY(KC,2)-1
27843           IF(MDME(IDC,1).LT.0) GOTO 520
27844           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27845           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27846           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27847           WID2=1D0
27848           IF(I.LE.6) THEN
27849 C...H_R++/-- -> l+/- + l'+/-
27850             FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27851      &      (IABS(KFDP(IDC,2))-9)/2)**2
27852             IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27853           ELSEIF(I.EQ.7) THEN
27854 C...H_R++/-- -> W_R+/- + W_R+/-
27855             FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27856             WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27857           ENDIF
27858           WDTP(I)=FAC*FCOF*
27859      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27860           WDTP(I)=FUDGE*WDTP(I)
27861           WDTP(0)=WDTP(0)+WDTP(I)
27862           IF(MDME(IDC,1).GT.0) THEN
27863             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27864             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27865             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27866             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27867           ENDIF
27868   520  CONTINUE
27869 
27870       ELSEIF(KFLA.EQ.KTECHN+115) THEN
27871 C...Techni-a2:
27872 C...Need to update to alpha_rho
27873         ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27874         FAC=(ALPRHT/12D0)*SHR
27875         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27876         SQMZ=PMAS(23,1)**2
27877         SQMW=PMAS(24,1)**2
27878         SHP=SH
27879         CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27880         GMMZ=SHR*WDTPP(0)
27881         XWRHT=1D0/(4D0*XW*(1D0-XW))
27882         BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27883         BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27884         DO 530 I=1,MDCY(KC,3)
27885           IDC=I+MDCY(KC,2)-1
27886           IF(MDME(IDC,1).LT.0) GOTO 530
27887           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27888           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27889           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27890           WID2=1D0
27891           PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27892           IF(I.LE.4) THEN
27893             FACPV=PCM**2
27894             FACPA=PCM**2+1.5D0*RM1            
27895             VA2=0D0
27896             AA2=0D0
27897 C...a2_tc0 -> W+ + W-
27898             IF(I.EQ.1) THEN
27899               AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27900 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27901               WID2=WIDS(24,1)
27902 C...a2_tc0 -> W+ + pi_tc- + c.c.
27903             ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27904               AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27905               IF(I.EQ.6) THEN
27906                 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27907               ELSE
27908                 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27909               ENDIF
27910             ELSEIF(I.EQ.4) THEN
27911 C...a2_tc0 -> Z0 + pi_tc0'
27912               VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27913               WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27914             ENDIF
27915             WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27916           ELSEIF(I.GE.5.AND.I.LE.10) THEN
27917             FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27918             FACPA=PCM**2*(1D0+RM1+RM2)
27919             VA2=0D0
27920             AA2=0D0
27921             IF(I.EQ.5) THEN
27922 C...a_T^0 -> gamma rho_T^0
27923               VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27924               WID2=WIDS(PYCOMP(KTECHN+113),2)
27925             ELSEIF(I.EQ.6) THEN
27926 C...a_T^0 -> gamma omega_T
27927               VA2=1D0/RTCM(50)**4
27928               WID2=WIDS(PYCOMP(KTECHN+223),2)
27929             ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27930 C...a_T^0 -> W^+- rho_T^-+
27931               AA2=.25D0/XW/RTCM(51)**4
27932               IF(I.EQ.7) THEN
27933                 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27934               ELSE
27935                 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27936               ENDIF
27937             ELSEIF(I.EQ.9) THEN
27938 C...a_T^0 -> Z^0 rho_T^0
27939               VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27940               WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27941             ELSEIF(I.EQ.10) THEN
27942 C...a_T^0 -> Z^0 omega_T
27943               VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27944               WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27945             ENDIF            
27946             WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27947           ELSE
27948 C...a2_tc0 -> f + fbar.
27949             WID2=1D0
27950             IF(I.LE.18) THEN
27951               IA=I-10
27952               FCOF=3D0*RADC
27953               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27954             ELSE
27955               IA=I-8
27956               FCOF=1D0
27957               IF(IA.GE.17) WID2=WIDS(IA,1)
27958             ENDIF
27959             EI=KCHG(IA,1)/3D0
27960             AI=SIGN(1D0,EI+0.1D0)
27961             VI=AI-4D0*EI*XWV
27962             VALI=0.5D0*(VI+AI)
27963             VARI=0.5D0*(VI-AI)
27964             WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27965      &      ((VALI*BWZR)**2+(VALI*BWZI)**2+
27966      &      (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27967      &      (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27968           ENDIF
27969           WDTP(I)=FUDGE*WDTP(I)
27970           WDTP(0)=WDTP(0)+WDTP(I)
27971           IF(MDME(IDC,1).GT.0) THEN
27972             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27973             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27974             WDTE(I,0)=WDTE(I,MDME(IDC,1))
27975             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27976           ENDIF
27977   530   CONTINUE
27978  
27979       ELSEIF(KFLA.EQ.KTECHN+215) THEN
27980 C...Techni-a2+/-:
27981         ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27982         FAC=(ALPRHT/12D0)*SHR
27983         SQMZ=PMAS(23,1)**2
27984         SQMW=PMAS(24,1)**2
27985         SHP=SH
27986         CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27987         GMMW=SHR*WDTPP(0)
27988         FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27989      &  (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27990         DO 540 I=1,MDCY(KC,3)
27991           IDC=I+MDCY(KC,2)-1
27992           IF(MDME(IDC,1).LT.0) GOTO 540
27993           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27994           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27995           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27996           WID2=1D0
27997           PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27998           IF(KFLR.GT.0) THEN
27999             ICHANN=2
28000           ELSE
28001             ICHANN=3
28002           ENDIF
28003           IF(I.LE.7) THEN
28004             AA2=0
28005             VA2=0
28006 C...a2_tc+ -> gamma + W+.
28007             IF(I.EQ.1) THEN
28008               AA2=RTCM(3)**2/RTCM(49)**2
28009               WID2=WIDS(24,ICHANN)
28010 C...a2_tc+ -> gamma + pi_tc+.
28011             ELSEIF(I.EQ.2) THEN
28012               AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
28013               WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
28014 C...a2_tc+ -> W+ + Z
28015             ELSEIF(I.EQ.3) THEN
28016               AA2=RTCM(3)**2*(1D0/4D0/XW1 +
28017      &                       (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
28018               WID2=WIDS(24,ICHANN)*WIDS(23,2)
28019 C...a2_tc+ -> W+ + pi_tc0.
28020             ELSEIF(I.EQ.4) THEN
28021               AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
28022               WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
28023 C...a2_tc+ -> W+ + pi_tc'0.
28024             ELSEIF(I.EQ.5) THEN
28025               VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
28026               WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
28027 C...a2_tc+ -> Z0 + pi_tc+.
28028             ELSEIF(I.EQ.6) THEN
28029               AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
28030      &         RTCM(49)**2
28031               WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
28032             ENDIF
28033             WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
28034      &      /3D0*SHR**3
28035           ELSEIF(I.LE.10) THEN
28036             FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
28037             FACPA=PCM**2*(1D0+RM1+RM2)
28038             VA2=0D0
28039             AA2=0D0
28040 C...a2_tc+ -> gamma + rho_tc+
28041             IF(I.EQ.7) THEN
28042               VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
28043               WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
28044 C...a2_tc+ -> W+ + rho_T^0
28045             ELSEIF(I.EQ.8) THEN
28046               AA2=1D0/(4D0*XW)/RTCM(51)**4
28047               WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
28048 C...a2_tc+ -> W+ + omega_T
28049             ELSEIF(I.EQ.9) THEN
28050               VA2=.25D0/XW/RTCM(50)**4
28051               WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
28052 C...a2_tc+ -> Z^0  + rho_T^+
28053             ELSEIF(I.EQ.10) THEN
28054               VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
28055               AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
28056               WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
28057             ENDIF            
28058             WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
28059           ELSE
28060 C...a2_tc+ -> f + fbar'.
28061             IA=I-10
28062             WID2=1D0
28063             IF(IA.LE.16) THEN
28064               FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
28065               IF(KFLR.GT.0) THEN
28066                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
28067                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
28068                 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
28069               ELSE
28070                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
28071                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
28072                 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
28073               ENDIF
28074             ELSE
28075               FCOF=1D0
28076               IF(KFLR.GT.0) THEN
28077                 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
28078               ELSE
28079                 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
28080               ENDIF
28081             ENDIF
28082             WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
28083      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28084           ENDIF
28085           WDTP(I)=FUDGE*WDTP(I)
28086           WDTP(0)=WDTP(0)+WDTP(I)
28087           IF(MDME(IDC,1).GT.0) THEN
28088             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
28089             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
28090             WDTE(I,0)=WDTE(I,MDME(IDC,1))
28091             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
28092           ENDIF
28093   540   CONTINUE
28094  
28095       ENDIF
28096       MINT(61)=0
28097       MINT(62)=0
28098       MINT(63)=0
28099       RETURN
28100       END
28101  
28102 C***********************************************************************
28103  
28104 C...PYOFSH
28105 C...Calculates partial width and differential cross-section maxima
28106 C...of channels/processes not allowed on mass-shell, and selects
28107 C...masses in such channels/processes.
28108  
28109       SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
28110  
28111 C...Double precision and integer declarations.
28112       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28113       IMPLICIT INTEGER(I-N)
28114       INTEGER PYK,PYCHGE,PYCOMP
28115 C...Commonblocks.
28116       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28117       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28118       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28119       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28120       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28121       COMMON/PYINT1/MINT(400),VINT(400)
28122       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28123       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28124       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
28125      &/PYINT2/,/PYINT5/
28126 C...Local arrays.
28127       DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
28128      &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
28129      &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
28130      &WDTE(0:400,0:5)
28131  
28132 C...Find if particles equal, maximum mass, matrix elements, etc.
28133       MINT(51)=0
28134       ISUB=MINT(1)
28135       KFD(1)=IABS(KFD1)
28136       KFD(2)=IABS(KFD2)
28137       MEQL=0
28138       IF(KFD(1).EQ.KFD(2)) MEQL=1
28139       MLM=0
28140       IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
28141       IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
28142         NOFF=44
28143         PMMX=PMMO
28144       ELSE
28145         NOFF=40
28146         PMMX=VINT(1)
28147         IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
28148       ENDIF
28149       MMED=0
28150 C      IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
28151       IF((KFMO.EQ.25.OR.KFMO.EQ.35).AND.MEQL.EQ.1.AND.
28152      &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
28153       IF(KFMO.EQ.36.AND.MEQL.EQ.1.AND.
28154      &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=4
28155       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
28156      &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
28157       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
28158      &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
28159       LOOP=1
28160  
28161 C...Find where Breit-Wigners are required, else select discrete masses.
28162   100 DO 110 I=1,2
28163         KFCA=PYCOMP(KFD(I))
28164         IF(KFCA.GT.0) THEN
28165           PMD(I)=PMAS(KFCA,1)
28166           PGD(I)=PMAS(KFCA,2)
28167         ELSE
28168           PMD(I)=0D0
28169           PGD(I)=0D0
28170         ENDIF
28171         IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
28172           MBW(I)=0
28173           PMG(I)=PMD(I)
28174           RMG(I)=(PMG(I)/PMMX)**2
28175         ELSE
28176           MBW(I)=1
28177         ENDIF
28178   110 CONTINUE
28179  
28180 C...Find allowed mass range and Breit-Wigner parameters.
28181       DO 120 I=1,2
28182         IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
28183           PML(I)=PARP(42)
28184           PMU(I)=PMMX-PARP(42)
28185           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28186           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28187         ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
28188           ILM=I
28189           IF(MLM.EQ.2) ILM=3-I
28190           PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
28191           IF(MBW(3-I).EQ.0) THEN
28192             PMU(I)=PMMX-PMD(3-I)
28193           ELSE
28194             PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
28195           ENDIF
28196           IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
28197      &    MIN(PMU(I),CKIN(NOFF+2*ILM))
28198           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28199           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28200           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28201           IF(MBW(I).EQ.1) THEN
28202             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28203             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28204             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28205      &      PGD(I)))
28206           ENDIF
28207         ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
28208           ILM=I
28209           IF(MLM.EQ.2) ILM=3-I
28210           PML(I)=MAX(CKIN(48+I),PARP(42))
28211           PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
28212           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28213           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28214           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28215           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28216           IF(MBW(I).EQ.1) THEN
28217             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28218             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28219             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28220      &      PGD(I)))
28221           ENDIF
28222         ENDIF
28223   120 CONTINUE
28224       IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
28225      &THEN
28226         CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
28227         MINT(51)=1
28228         RETURN
28229       ENDIF
28230  
28231 C...Calculation of partial width of resonance.
28232       IF(MOFSH.EQ.1) THEN
28233  
28234 C..If only one integration, pick that to be the inner.
28235         IF(MBW(1).EQ.0) THEN
28236           PM2=PMD(1)
28237           PMD(1)=PMD(2)
28238           PGD(1)=PGD(2)
28239           PML(1)=PML(2)
28240           PMU(1)=PMU(2)
28241         ELSEIF(MBW(2).EQ.0) THEN
28242           PM2=PMD(2)
28243         ENDIF
28244  
28245 C...Start outer loop of integration.
28246         IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28247           ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28248           ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28249           NPT2=1
28250           XPT2(1)=1D0
28251           INX2(1)=0
28252           FMAX2=0D0
28253         ENDIF
28254   130   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28255           PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
28256           PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
28257         ENDIF
28258         RM2=(PM2/PMMX)**2
28259  
28260 C...Start inner loop of integration.
28261         PML1=PML(1)
28262         PMU1=MIN(PMU(1),PMMX-PM2)
28263         IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
28264         ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28265         ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28266         IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
28267           FUNC2=0D0
28268           GOTO 180
28269         ENDIF
28270         NPT1=1
28271         XPT1(1)=1D0
28272         INX1(1)=0
28273         FMAX1=0D0
28274   140   PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
28275         PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
28276         RM1=(PM1/PMMX)**2
28277  
28278 C...Evaluate function value - inner loop.
28279         FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28280         IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
28281         IF(MMED.EQ.4) FUNC1=FUNC1**3*RM1*RM2
28282         IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
28283      &  RM2**2+10D0*RM1*RM2)
28284         IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
28285         FPT1(NPT1)=FUNC1
28286  
28287 C...Go to next position in inner loop.
28288         IF(NPT1.EQ.1) THEN
28289           NPT1=NPT1+1
28290           XPT1(NPT1)=0D0
28291           INX1(NPT1)=1
28292           GOTO 140
28293         ELSEIF(NPT1.LE.8) THEN
28294           NPT1=NPT1+1
28295           IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
28296           ISH1=ISH1+1
28297           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28298           INX1(NPT1)=INX1(ISH1)
28299           INX1(ISH1)=NPT1
28300           GOTO 140
28301         ELSEIF(NPT1.LT.100) THEN
28302           ISN1=ISH1
28303   150     ISH1=ISH1+1
28304           IF(ISH1.GT.NPT1) ISH1=2
28305           IF(ISH1.EQ.ISN1) GOTO 160
28306           DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
28307           IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
28308           NPT1=NPT1+1
28309           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28310           INX1(NPT1)=INX1(ISH1)
28311           INX1(ISH1)=NPT1
28312           GOTO 140
28313         ENDIF
28314  
28315 C...Calculate integral over inner loop.
28316   160   FSUM1=0D0
28317         DO 170 IPT1=2,NPT1
28318           FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
28319      &    (XPT1(INX1(IPT1))-XPT1(IPT1))
28320   170   CONTINUE
28321         FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
28322   180   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28323           IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
28324           FPT2(NPT2)=FUNC2
28325  
28326 C...Go to next position in outer loop.
28327           IF(NPT2.EQ.1) THEN
28328             NPT2=NPT2+1
28329             XPT2(NPT2)=0D0
28330             INX2(NPT2)=1
28331             GOTO 130
28332           ELSEIF(NPT2.LE.8) THEN
28333             NPT2=NPT2+1
28334             IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
28335             ISH2=ISH2+1
28336             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28337             INX2(NPT2)=INX2(ISH2)
28338             INX2(ISH2)=NPT2
28339             GOTO 130
28340           ELSEIF(NPT2.LT.100) THEN
28341             ISN2=ISH2
28342   190       ISH2=ISH2+1
28343             IF(ISH2.GT.NPT2) ISH2=2
28344             IF(ISH2.EQ.ISN2) GOTO 200
28345             DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
28346             IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
28347             NPT2=NPT2+1
28348             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28349             INX2(NPT2)=INX2(ISH2)
28350             INX2(ISH2)=NPT2
28351             GOTO 130
28352           ENDIF
28353  
28354 C...Calculate integral over outer loop.
28355   200     FSUM2=0D0
28356           DO 210 IPT2=2,NPT2
28357             FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
28358      &      (XPT2(INX2(IPT2))-XPT2(IPT2))
28359   210     CONTINUE
28360           FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
28361           IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
28362         ELSE
28363           FSUM2=FUNC2
28364         ENDIF
28365  
28366 C...Save result; second integration for user-selected mass range.
28367         IF(LOOP.EQ.1) WIDW=FSUM2
28368         WID2=FSUM2
28369         IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
28370      &  .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
28371           LOOP=2
28372           GOTO 100
28373         ENDIF
28374         RET1=WIDW
28375         RET2=WID2/WIDW
28376  
28377 C...Select two decay product masses of a resonance.
28378       ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
28379   220   DO 230 I=1,2
28380           IF(MBW(I).EQ.0) GOTO 230
28381           PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
28382      &    (ATU(I)-ATL(I)))
28383           PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
28384           RMG(I)=(PMG(I)/PMMX)**2
28385   230   CONTINUE
28386         IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28387      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
28388  
28389 C...Weight with matrix element (if none known, use beta factor).
28390         FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
28391         IF(MMED.EQ.1) THEN
28392           WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
28393         ELSEIF(MMED.EQ.4) THEN
28394           WTBE=FLAM**3*RMG(1)*RMG(2)
28395         ELSEIF(MMED.EQ.2) THEN
28396           WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
28397      &    RMG(2)**2+10D0*RMG(1)*RMG(2))
28398         ELSEIF(MMED.EQ.3) THEN
28399           WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
28400         ELSE
28401           WTBE=FLAM
28402         ENDIF
28403         IF(WTBE.LT.PYR(0)) GOTO 220
28404         RET1=PMG(1)
28405         RET2=PMG(2)
28406  
28407 C...Find suitable set of masses for initialization of 2 -> 2 processes.
28408       ELSEIF(MOFSH.EQ.3) THEN
28409         IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
28410           PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
28411           PMG(2)=PMD(2)
28412         ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
28413           PMG(1)=PMD(1)
28414           PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
28415         ELSE
28416           IDIV=-1
28417   240     IDIV=IDIV+1
28418           PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
28419           PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
28420           IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
28421         ENDIF
28422         RET1=PMG(1)
28423         RET2=PMG(2)
28424  
28425 C...Evaluate importance of excluded tails of Breit-Wigners.
28426         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28427      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28428         IF(MEQL.LE.1) THEN
28429           VINT(80)=1D0
28430           DO 250 I=1,2
28431             IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
28432      &      PARU(1)
28433   250     CONTINUE
28434         ELSE
28435           VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
28436      &    (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
28437         ENDIF
28438         IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
28439      &  MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
28440         IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
28441         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28442  
28443 C...Pick one particle to be the lighter (if improves efficiency).
28444       ELSEIF(MOFSH.EQ.4) THEN
28445         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28446      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28447   260   IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
28448  
28449 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
28450         DO 270 I=1,2
28451           IF(MBW(I).EQ.0) GOTO 270
28452           PMV=PMU(I)
28453           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28454           ATV=ATU(I)
28455           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28456           RBR=PYR(0)
28457           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28458      &    ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
28459           IF(RBR.LT.0.8D0) THEN
28460             PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
28461             PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
28462           ELSEIF(RBR.LT.0.9D0) THEN
28463             PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
28464           ELSEIF(RBR.LT.1.5D0) THEN
28465             PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
28466           ELSE
28467             PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
28468      &      (PMV**2-PML(I)**2))))
28469           ENDIF
28470   270   CONTINUE
28471         IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28472      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
28473           IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
28474             NGEN(0,1)=NGEN(0,1)+1
28475             NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
28476             GOTO 260
28477           ELSE
28478             MINT(51)=1
28479             RETURN
28480           ENDIF
28481         ENDIF
28482         RET1=PMG(1)
28483         RET2=PMG(2)
28484  
28485 C...Give weight for selected mass distribution.
28486         VINT(80)=1D0
28487         DO 280 I=1,2
28488           IF(MBW(I).EQ.0) GOTO 280
28489           PMV=PMU(I)
28490           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28491           ATV=ATU(I)
28492           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28493           F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
28494      &    (PMD(I)*PGD(I))**2)/PARU(1)
28495           F1=1D0
28496           F2=1D0/PMG(I)**2
28497           F3=1D0/PMG(I)**4
28498           FI0=(ATV-ATL(I))/PARU(1)
28499           FI1=PMV**2-PML(I)**2
28500           FI2=2D0*LOG(PMV/PML(I))
28501           FI3=1D0/PML(I)**2-1D0/PMV**2
28502           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28503      &    ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
28504             VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
28505      &      5D0*F3/FI3))
28506           ELSE
28507             VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
28508           ENDIF
28509           VINT(80)=VINT(80)*FI0
28510   280   CONTINUE
28511         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28512       ENDIF
28513  
28514       RETURN
28515       END
28516  
28517 C***********************************************************************
28518  
28519 C...PYRECO
28520 C...Handles the possibility of colour reconnection in W+W- events,
28521 C...Based on the main scenarios of the Sjostrand and Khoze study:
28522 C...I, II, II', intermediate and instantaneous; plus one model
28523 C...along the lines of the Gustafson and Hakkinen: GH.
28524 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
28525 C...is as if first resonance is W+ and second W-.
28526  
28527       SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
28528  
28529 C...Double precision and integer declarations.
28530       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28531       IMPLICIT INTEGER(I-N)
28532       INTEGER PYK,PYCHGE,PYCOMP
28533 C...Parameter value; number of points in MC integration.
28534       PARAMETER (NPT=100)
28535 C...Commonblocks.
28536       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28537       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28538       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28539       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28540       COMMON/PYINT1/MINT(400),VINT(400)
28541       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28542 C...Local arrays.
28543       DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
28544      &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
28545      &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
28546      &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
28547      &TMC(20),IJOIN(100)
28548  
28549 C...Functions to give four-product and to do determinants.
28550       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)
28551       DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
28552      &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
28553      &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
28554  
28555 C...Only allow fraction of recoupling for GH, intermediate and
28556 C...instantaneous.
28557       IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28558         IF(PYR(0).GT.PARP(120)) RETURN
28559       ENDIF
28560       ISUB=MINT(1)
28561  
28562 C...Common part for scenarios I, II, II', and GH.
28563       IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
28564      &MSTP(115).EQ.5) THEN
28565  
28566 C...Read out frequently-used parameters.
28567         PI=PARU(1)
28568         HBAR=PARU(3)
28569         PMW=PMAS(24,1)
28570         IF(ISUB.EQ.22) PMW=PMAS(23,1)
28571         PGW=PMAS(24,2)
28572         IF(ISUB.EQ.22) PGW=PMAS(23,2)
28573         TFRAG=PARP(115)
28574         RHAD=PARP(116)
28575         FACT=PARP(117)
28576         BLOWR=PARP(118)
28577         BLOWT=PARP(119)
28578  
28579 C...Find range of decay products of the W's.
28580 C...Background: the W's are stored in IW1 and IW2.
28581 C...Their direct decay products in NSD1+1 through NSD1+4.
28582 C...Products after shower (if any) in NSD1+5 through NAFT1
28583 C...for first W and in NAFT1+1 through N for the second.
28584         IF(NAFT1.GT.NSD1+4) THEN
28585           NBEG(1)=NSD1+5
28586           NEND(1)=NAFT1
28587         ELSE
28588           NBEG(1)=NSD1+1
28589           NEND(1)=NSD1+2
28590         ENDIF
28591         IF(N.GT.NAFT1) THEN
28592           NBEG(2)=NAFT1+1
28593           NEND(2)=N
28594         ELSE
28595           NBEG(2)=NSD1+3
28596           NEND(2)=NSD1+4
28597         ENDIF
28598  
28599 C...Rearrange parton shower products along strings.
28600         NOLD=N
28601         CALL PYPREP(NSD1+1)
28602         IF(MINT(51).NE.0) RETURN
28603  
28604 C...Find partons pointing back to W+ and W-; store them with quark
28605 C...end of string first.
28606         NNP=0
28607         NNM=0
28608         ISGP=0
28609         ISGM=0
28610         DO 120 I=NOLD+1,N
28611           IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
28612           IF(IABS(K(I,2)).GE.22) GOTO 120
28613           IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
28614             IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
28615             NNP=NNP+1
28616             IF(ISGP.EQ.1) THEN
28617               INP(NNP)=I
28618             ELSE
28619               DO 100 I1=NNP,2,-1
28620                 INP(I1)=INP(I1-1)
28621   100         CONTINUE
28622               INP(1)=I
28623             ENDIF
28624             IF(K(I,1).EQ.1) ISGP=0
28625           ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
28626             IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
28627             NNM=NNM+1
28628             IF(ISGM.EQ.1) THEN
28629               INM(NNM)=I
28630             ELSE
28631               DO 110 I1=NNM,2,-1
28632                 INM(I1)=INM(I1-1)
28633   110         CONTINUE
28634               INM(1)=I
28635             ENDIF
28636             IF(K(I,1).EQ.1) ISGM=0
28637           ENDIF
28638   120   CONTINUE
28639  
28640 C...Boost to W+W- rest frame (not strictly needed).
28641         DO 130 J=1,3
28642           BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
28643   130   CONTINUE
28644         CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28645         CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28646         CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28647  
28648 C...Select decay vertices of W+ and W-.
28649         TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28650      &  SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28651         TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28652      &  SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28653         GTMAX=MAX(TP,TM)
28654         DO 140 J=1,3
28655           XP(J)=TP*P(IW1,J)/P(IW1,4)
28656           XM(J)=TM*P(IW2,J)/P(IW2,4)
28657   140   CONTINUE
28658  
28659 C...Begin scenario I specifics.
28660         IF(MSTP(115).EQ.1) THEN
28661  
28662 C...Reconstruct velocity and direction of W+ string pieces.
28663           DO 170 IIP=1,NNP-1
28664             IF(K(INP(IIP),2).LT.0) GOTO 170
28665             I1=INP(IIP)
28666             I2=INP(IIP+1)
28667             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28668             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28669             DO 150 J=1,3
28670               V1(J)=P(I1,J)/P1A
28671               V2(J)=P(I2,J)/P2A
28672               BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28673               DIRP(IIP,J)=V1(J)-V2(J)
28674   150       CONTINUE
28675             BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28676      &      BETP(IIP,3)**2)
28677             DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28678             DO 160 J=1,3
28679               DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28680   160       CONTINUE
28681   170     CONTINUE
28682  
28683 C...Reconstruct velocity and direction of W- string pieces.
28684           DO 200 IIM=1,NNM-1
28685             IF(K(INM(IIM),2).LT.0) GOTO 200
28686             I1=INM(IIM)
28687             I2=INM(IIM+1)
28688             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28689             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28690             DO 180 J=1,3
28691               V1(J)=P(I1,J)/P1A
28692               V2(J)=P(I2,J)/P2A
28693               BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28694               DIRM(IIM,J)=V1(J)-V2(J)
28695   180       CONTINUE
28696             BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28697      &      BETM(IIM,3)**2)
28698             DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28699             DO 190 J=1,3
28700               DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28701   190       CONTINUE
28702   200     CONTINUE
28703  
28704 C...Loop over number of space-time points.
28705           NACC=0
28706           SUM=0D0
28707           DO 250 IPT=1,NPT
28708  
28709 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28710             R=SQRT(-LOG(PYR(0)))
28711             PHI=2D0*PI*PYR(0)
28712             X=BLOWR*RHAD*R*COS(PHI)
28713             Y=BLOWR*RHAD*R*SIN(PHI)
28714             R=SQRT(-LOG(PYR(0)))
28715             PHI=2D0*PI*PYR(0)
28716             Z=BLOWR*RHAD*R*COS(PHI)
28717             T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28718  
28719 C...Reject impossible points. Weight for sample distribution.
28720             IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28721             WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28722      &      EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28723  
28724 C...Loop over W+ string pieces and find one with largest weight.
28725             IMAXP=0
28726             WTMAXP=1D-10
28727             XD(1)=X-XP(1)
28728             XD(2)=Y-XP(2)
28729             XD(3)=Z-XP(3)
28730             XD(4)=T-TP
28731             DO 220 IIP=1,NNP-1
28732               IF(K(INP(IIP),2).LT.0) GOTO 220
28733               BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28734               BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28735               DO 210 J=1,3
28736                 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28737   210         CONTINUE
28738               XB(4)=BETP(IIP,4)*(XD(4)-BED)
28739               SR2=XB(1)**2+XB(2)**2+XB(3)**2
28740               SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28741      &        DIRP(IIP,3)*XB(3))**2
28742               WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28743      &        TFRAG**2)
28744               IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28745               IF(WTP.GT.WTMAXP) THEN
28746                 IMAXP=IIP
28747                 WTMAXP=WTP
28748               ENDIF
28749   220       CONTINUE
28750  
28751 C...Loop over W- string pieces and find one with largest weight.
28752             IMAXM=0
28753             WTMAXM=1D-10
28754             XD(1)=X-XM(1)
28755             XD(2)=Y-XM(2)
28756             XD(3)=Z-XM(3)
28757             XD(4)=T-TM
28758             DO 240 IIM=1,NNM-1
28759               IF(K(INM(IIM),2).LT.0) GOTO 240
28760               BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28761               BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28762               DO 230 J=1,3
28763                 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28764   230         CONTINUE
28765               XB(4)=BETM(IIM,4)*(XD(4)-BED)
28766               SR2=XB(1)**2+XB(2)**2+XB(3)**2
28767               SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28768      &        DIRM(IIM,3)*XB(3))**2
28769               WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28770      &        TFRAG**2)
28771               IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28772               IF(WTM.GT.WTMAXM) THEN
28773                 IMAXM=IIM
28774                 WTMAXM=WTM
28775               ENDIF
28776   240       CONTINUE
28777  
28778 C...Result of integration.
28779             WT=0D0
28780             IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28781               WT=WTMAXP*WTMAXM/WTSMP
28782               SUM=SUM+WT
28783               NACC=NACC+1
28784               IAP(NACC)=IMAXP
28785               IAM(NACC)=IMAXM
28786               WTA(NACC)=WT
28787             ENDIF
28788   250     CONTINUE
28789           RES=BLOWR**3*BLOWT*SUM/NPT
28790  
28791 C...Decide whether to reconnect and, if so, where.
28792           IACC=0
28793           PREC=1D0-EXP(-FACT*RES)
28794           IF(PREC.GT.PYR(0)) THEN
28795             RSUM=PYR(0)*SUM
28796             DO 260 IA=1,NACC
28797               IACC=IA
28798               RSUM=RSUM-WTA(IA)
28799               IF(RSUM.LE.0D0) GOTO 270
28800   260       CONTINUE
28801   270       IIP=IAP(IACC)
28802             IIM=IAM(IACC)
28803           ENDIF
28804  
28805 C...Begin scenario II and II' specifics.
28806         ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28807  
28808 C...Loop through all string pieces, one from W+ and one from W-.
28809           NCROSS=0
28810           TC(0)=0D0
28811           DO 340 IIP=1,NNP-1
28812             IF(K(INP(IIP),2).LT.0) GOTO 340
28813             I1P=INP(IIP)
28814             I2P=INP(IIP+1)
28815             DO 330 IIM=1,NNM-1
28816               IF(K(INM(IIM),2).LT.0) GOTO 330
28817               I1M=INM(IIM)
28818               I2M=INM(IIM+1)
28819  
28820 C...Find endpoint velocity vectors.
28821               DO 280 J=1,3
28822                 V1P(J)=P(I1P,J)/P(I1P,4)
28823                 V2P(J)=P(I2P,J)/P(I2P,4)
28824                 V1M(J)=P(I1M,J)/P(I1M,4)
28825                 V2M(J)=P(I2M,J)/P(I2M,4)
28826   280         CONTINUE
28827  
28828 C...Define q matrix and find t.
28829               DO 290 J=1,3
28830                 Q(1,J)=V2P(J)-V1P(J)
28831                 Q(2,J)=-(V2M(J)-V1M(J))
28832                 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28833                 Q(4,J)=V1P(J)-V1M(J)
28834   290         CONTINUE
28835               T=-DETER(1,2,3)/DETER(1,2,4)
28836  
28837 C...Find alpha and beta; i.e. coordinates of crossing point.
28838               S11=Q(1,1)*(T-TP)
28839               S12=Q(2,1)*(T-TM)
28840               S13=Q(3,1)+Q(4,1)*T
28841               S21=Q(1,2)*(T-TP)
28842               S22=Q(2,2)*(T-TM)
28843               S23=Q(3,2)+Q(4,2)*T
28844               DEN=S11*S22-S12*S21
28845               ALP=(S12*S23-S22*S13)/DEN
28846               BET=(S21*S13-S11*S23)/DEN
28847  
28848 C...Check if solution acceptable.
28849               IANSW=1
28850               IF(T.LT.GTMAX) IANSW=0
28851               IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28852               IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28853  
28854 C...Find point of crossing and check that not inconsistent.
28855               DO 300 J=1,3
28856                 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28857                 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28858   300         CONTINUE
28859               D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28860      &        (XPP(3)-XMM(3))**2
28861               D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28862               D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28863               IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28864  
28865 C...Find string eigentimes at crossing.
28866               IF(IANSW.EQ.1) THEN
28867                 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28868      &          (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28869                 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28870      &          (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28871               ELSE
28872                 TAUP=0D0
28873                 TAUM=0D0
28874               ENDIF
28875  
28876 C...Order crossings by time. End loop over crossings.
28877               IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28878                 NCROSS=NCROSS+1
28879                 DO 310 I1=NCROSS,1,-1
28880                   IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28881                     IPC(I1)=IIP
28882                     IMC(I1)=IIM
28883                     TC(I1)=T
28884                     TPC(I1)=TAUP
28885                     TMC(I1)=TAUM
28886                     GOTO 320
28887                   ELSE
28888                     IPC(I1)=IPC(I1-1)
28889                     IMC(I1)=IMC(I1-1)
28890                     TC(I1)=TC(I1-1)
28891                     TPC(I1)=TPC(I1-1)
28892                     TMC(I1)=TMC(I1-1)
28893                   ENDIF
28894   310           CONTINUE
28895   320           CONTINUE
28896               ENDIF
28897   330       CONTINUE
28898   340     CONTINUE
28899  
28900 C...Loop over crossings; find first (if any) acceptable one.
28901           IACC=0
28902           IF(NCROSS.GE.1) THEN
28903             DO 350 IC=1,NCROSS
28904               PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28905               IF(PNFRAG.GT.PYR(0)) THEN
28906 C...Scenario II: only compare with fragmentation time.
28907                 IF(MSTP(115).EQ.2) THEN
28908                   IACC=IC
28909                   IIP=IPC(IACC)
28910                   IIM=IMC(IACC)
28911                   GOTO 360
28912 C...Scenario II': also require that string length decreases.
28913                 ELSE
28914                   IIP=IPC(IC)
28915                   IIM=IMC(IC)
28916                   I1P=INP(IIP)
28917                   I2P=INP(IIP+1)
28918                   I1M=INM(IIM)
28919                   I2M=INM(IIM+1)
28920                   ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28921                   ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28922                   IF(ELNEW.LT.ELOLD) THEN
28923                     IACC=IC
28924                     IIP=IPC(IACC)
28925                     IIM=IMC(IACC)
28926                     GOTO 360
28927                   ENDIF
28928                 ENDIF
28929               ENDIF
28930   350       CONTINUE
28931   360       CONTINUE
28932           ENDIF
28933  
28934 C...Begin scenario GH specifics.
28935         ELSEIF(MSTP(115).EQ.5) THEN
28936  
28937 C...Loop through all string pieces, one from W+ and one from W-.
28938           IACC=0
28939           ELMIN=1D0
28940           DO 380 IIP=1,NNP-1
28941             IF(K(INP(IIP),2).LT.0) GOTO 380
28942             I1P=INP(IIP)
28943             I2P=INP(IIP+1)
28944             DO 370 IIM=1,NNM-1
28945               IF(K(INM(IIM),2).LT.0) GOTO 370
28946               I1M=INM(IIM)
28947               I2M=INM(IIM+1)
28948  
28949 C...Look for largest decrease of (exponent of) Lambda measure.
28950               ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28951               ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28952               ELDIF=ELNEW/MAX(1D-10,ELOLD)
28953               IF(ELDIF.LT.ELMIN) THEN
28954                 IACC=IIP+IIM
28955                 ELMIN=ELDIF
28956                 IPC(1)=IIP
28957                 IMC(1)=IIM
28958               ENDIF
28959   370       CONTINUE
28960   380     CONTINUE
28961           IIP=IPC(1)
28962           IIM=IMC(1)
28963         ENDIF
28964  
28965 C...Common for scenarios I, II, II' and GH: reconnect strings.
28966         IF(IACC.NE.0) THEN
28967           MINT(32)=1
28968           NJOIN=0
28969           DO 390 IS=1,NNP+NNM
28970             NJOIN=NJOIN+1
28971             IF(IS.LE.IIP) THEN
28972               I=INP(IS)
28973             ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28974               I=INM(IS-IIP+IIM)
28975             ELSEIF(IS.LE.IIP+NNM) THEN
28976               I=INM(IS-IIP-NNM+IIM)
28977             ELSE
28978               I=INP(IS-NNM)
28979             ENDIF
28980             IJOIN(NJOIN)=I
28981             IF(K(I,2).LT.0) THEN
28982               CALL PYJOIN(NJOIN,IJOIN)
28983               NJOIN=0
28984             ENDIF
28985   390     CONTINUE
28986  
28987 C...Restore original event record if no reconnection.
28988         ELSE
28989           DO 400 I=NSD1+1,NOLD
28990             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28991               K(I,4)=MOD(K(I,4),MSTU(5)**2)
28992               K(I,5)=MOD(K(I,5),MSTU(5)**2)
28993             ENDIF
28994   400     CONTINUE
28995           DO 410 I=NOLD+1,N
28996             K(K(I,3),1)=3
28997   410     CONTINUE
28998           N=NOLD
28999         ENDIF
29000  
29001 C...Boost back system.
29002         CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29003         CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29004         IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
29005      &  BEWW(1),BEWW(2),BEWW(3))
29006  
29007 C...Common part for intermediate and instantaneous scenarios.
29008       ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
29009         MINT(32)=1
29010  
29011 C...Remove old shower products and reset showering ones.
29012         N=NSD1+4
29013         DO 420 I=NSD1+1,NSD1+4
29014           K(I,1)=3
29015           K(I,4)=MOD(K(I,4),MSTU(5)**2)
29016           K(I,5)=MOD(K(I,5),MSTU(5)**2)
29017   420   CONTINUE
29018  
29019 C...Identify quark-antiquark pairs.
29020         IQ1=NSD1+1
29021         IQ2=NSD1+2
29022         IQ3=NSD1+3
29023         IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
29024         IQ4=2*NSD1+7-IQ3
29025  
29026 C...Reconnect strings.
29027         IJOIN(1)=IQ1
29028         IJOIN(2)=IQ4
29029         CALL PYJOIN(2,IJOIN)
29030         IJOIN(1)=IQ3
29031         IJOIN(2)=IQ2
29032         CALL PYJOIN(2,IJOIN)
29033  
29034 C...Do new parton showers in intermediate scenario.
29035         IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
29036           MSTJ50=MSTJ(50)
29037           MSTJ(50)=0
29038           CALL PYSHOW(IQ1,IQ2,P(IW1,5))
29039           CALL PYSHOW(IQ3,IQ4,P(IW2,5))
29040           MSTJ(50)=MSTJ50
29041  
29042 C...Do new parton showers in instantaneous scenario.
29043         ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
29044           PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
29045      &    (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
29046           PPM=SQRT(MAX(0D0,PPM2))
29047           CALL PYSHOW(IQ1,IQ4,PPM)
29048           PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
29049      &    (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
29050           PPM=SQRT(MAX(0D0,PPM2))
29051           CALL PYSHOW(IQ3,IQ2,PPM)
29052         ENDIF
29053       ENDIF
29054  
29055       RETURN
29056       END
29057  
29058 C***********************************************************************
29059  
29060 C...PYKLIM
29061 C...Checks generated variables against pre-set kinematical limits;
29062 C...also calculates limits on variables used in generation.
29063  
29064       SUBROUTINE PYKLIM(ILIM)
29065  
29066 C...Double precision and integer declarations.
29067       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29068       IMPLICIT INTEGER(I-N)
29069       INTEGER PYK,PYCHGE,PYCOMP
29070 C...Commonblocks.
29071       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29072       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29073       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29074       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29075       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29076       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29077       COMMON/PYINT1/MINT(400),VINT(400)
29078       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29079       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29080      &/PYINT1/,/PYINT2/
29081  
29082 C...Common kinematical expressions.
29083       MINT(51)=0
29084       ISUB=MINT(1)
29085       ISTSB=ISET(ISUB)
29086       IF(ISUB.EQ.96) GOTO 100
29087       SQM3=VINT(63)
29088       SQM4=VINT(64)
29089       IF(ILIM.NE.0) THEN
29090         IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
29091           CKIN09=MAX(CKIN(9),CKIN(13))
29092           CKIN10=MIN(CKIN(10),CKIN(14))
29093           CKIN11=MAX(CKIN(11),CKIN(15))
29094           CKIN12=MIN(CKIN(12),CKIN(16))
29095         ELSE
29096           CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
29097           CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
29098           CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
29099           CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
29100         ENDIF
29101       ENDIF
29102       IF(ILIM.NE.1) THEN
29103         TAU=VINT(21)
29104         RM3=SQM3/(TAU*VINT(2))
29105         RM4=SQM4/(TAU*VINT(2))
29106         BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29107       ENDIF
29108       PTHMIN=CKIN(3)
29109       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
29110      &PTHMIN=MAX(CKIN(3),CKIN(5))
29111  
29112       IF(ILIM.EQ.0) THEN
29113 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
29114 C...pre-set kinematical limits.
29115         YST=VINT(22)
29116         CTH=VINT(23)
29117         TAUP=VINT(26)
29118         TAUE=TAU
29119         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29120         X1=SQRT(TAUE)*EXP(YST)
29121         X2=SQRT(TAUE)*EXP(-YST)
29122         XF=X1-X2
29123         IF(MINT(47).NE.1) THEN
29124           IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
29125           IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
29126           IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
29127           IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
29128         ENDIF
29129         IF(MINT(45).NE.1) THEN
29130           IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
29131         ENDIF
29132         IF(MINT(46).NE.1) THEN
29133           IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
29134         ENDIF
29135         IF(MINT(45).EQ.2) THEN
29136           IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29137         ENDIF
29138         IF(MINT(46).EQ.2) THEN
29139           IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29140         ENDIF
29141         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29142           PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
29143           EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
29144      &    MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
29145           EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
29146      &    MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
29147           Y3=YST+0.5D0*LOG(EXPY3)
29148           Y4=YST+0.5D0*LOG(EXPY4)
29149           YLARGE=MAX(Y3,Y4)
29150           YSMALL=MIN(Y3,Y4)
29151           ETALAR=20D0
29152           ETASMA=-20D0
29153           STH=SQRT(MAX(0D0,1D0-CTH**2))
29154           EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
29155      &    CTH)**2-4D0*RM3))
29156           EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
29157      &    CTH)**2-4D0*RM4))
29158           IF(STH.GE.1D-10) THEN
29159             EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
29160      &      (BE34*STH)
29161             EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
29162      &      (BE34*STH)
29163             ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
29164             ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
29165             ETALAR=MAX(ETA3,ETA4)
29166             ETASMA=MIN(ETA3,ETA4)
29167           ENDIF
29168           CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
29169           CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
29170           CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
29171           CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
29172           SH=TAU*VINT(2)
29173           RPTS=4D0*VINT(71)**2/SH
29174           BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29175           RM34=MAX(1D-20,2D0*RM3*RM4)
29176           IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29177      &    RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29178           RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29179           THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
29180           UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29181           IF(PTH.LT.PTHMIN) MINT(51)=1
29182           IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
29183           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
29184           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
29185           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
29186           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
29187           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
29188           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
29189           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
29190           IF(THA.LT.CKIN(35)) MINT(51)=1
29191           IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
29192           IF(UHA.LT.CKIN(37)) MINT(51)=1
29193           IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
29194         ENDIF
29195         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29196           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
29197           IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
29198         ENDIF
29199  
29200 C...Additional cuts on W2 (approximately) in DIS.
29201         IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
29202           XBJ=X2
29203           IF(IABS(MINT(12)).LT.20) XBJ=X1
29204           Q2BJ=THA
29205           W2BJ=Q2BJ*(1D0-XBJ)/XBJ
29206           IF(W2BJ.LT.CKIN(39)) MINT(51)=1
29207           IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
29208         ENDIF
29209  
29210       ELSEIF(ILIM.EQ.1) THEN
29211 C...Calculate limits on tau
29212 C...0) due to definition
29213         TAUMN0=0D0
29214         TAUMX0=1D0
29215 C...1) due to limits on subsystem mass
29216         TAUMN1=CKIN(1)**2/VINT(2)
29217         TAUMX1=1D0
29218         IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
29219 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
29220         TM3=SQRT(SQM3+PTHMIN**2)
29221         TM4=SQRT(SQM4+PTHMIN**2)
29222         YDCOSH=1D0
29223         IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
29224         TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
29225         TAUMX2=1D0
29226 C...3) due to limits on pT-hat and cos(theta-hat)
29227         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
29228         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
29229         TAUMN3=0D0
29230         IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
29231      &  (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
29232      &  SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
29233         TAUMX3=1D0
29234         IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
29235      &  (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
29236      &  SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
29237 C...4) due to limits on x1 and x2
29238         TAUMN4=CKIN(21)*CKIN(23)
29239         TAUMX4=CKIN(22)*CKIN(24)
29240 C...5) due to limits on xF
29241         TAUMN5=0D0
29242         TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
29243 C...6) due to limits on that and uhat
29244         TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
29245         TAUMX6=1D0
29246         IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
29247      &  (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
29248  
29249 C...Net effect of all separate limits.
29250         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
29251         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
29252         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29253           VINT(11)=1D0-1D-9
29254           VINT(31)=1D0+1D-9
29255         ELSEIF(MINT(47).EQ.5) THEN
29256           VINT(31)=MIN(VINT(31),1D0-2D-10)
29257         ELSEIF(MINT(47).GE.6) THEN
29258           VINT(31)=MIN(VINT(31),1D0-1D-10)
29259         ENDIF
29260         IF(VINT(31).LE.VINT(11)) MINT(51)=1
29261  
29262       ELSEIF(ILIM.EQ.2) THEN
29263 C...Calculate limits on y*
29264         TAUE=TAU
29265         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29266         TAURT=SQRT(TAUE)
29267 C...0) due to kinematics
29268         YSTMN0=LOG(TAURT)
29269         YSTMX0=-YSTMN0
29270 C...1) due to explicit limits
29271         YSTMN1=CKIN(7)
29272         YSTMX1=CKIN(8)
29273 C...2) due to limits on x1
29274         YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
29275         YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
29276 C...3) due to limits on x2
29277         YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
29278         YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
29279 C...4) due to limits on xF
29280         YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
29281         YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
29282         YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
29283         YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
29284 C...5) due to simultaneous limits on y-large and y-small
29285         YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
29286         YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
29287         YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
29288         YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
29289         YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
29290         YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
29291 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
29292 C...   y-small
29293         CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
29294         RZMN=BE34*MAX(CKIN(27),-CTHLIM)
29295         RZMX=BE34*MIN(CKIN(28),CTHLIM)
29296         YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
29297         YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
29298         YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
29299         YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
29300         YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
29301         YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
29302  
29303 C...Net effect of all separate limits.
29304         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
29305         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
29306         IF(MINT(47).EQ.1) THEN
29307           VINT(12)=-1D-9
29308           VINT(32)=1D-9
29309         ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29310           VINT(12)=(1D0-1D-9)*YSTMX0
29311           VINT(32)=(1D0+1D-9)*YSTMX0
29312         ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29313           VINT(12)=-(1D0+1D-9)*YSTMX0
29314           VINT(32)=-(1D0-1D-9)*YSTMX0
29315         ELSEIF(MINT(47).EQ.5) THEN
29316           YSTEE=LOG((1D0-1D-10)/TAURT)
29317           VINT(12)=MAX(VINT(12),-YSTEE)
29318           VINT(32)=MIN(VINT(32),YSTEE)
29319         ENDIF
29320         IF(VINT(32).LE.VINT(12)) MINT(51)=1
29321  
29322       ELSEIF(ILIM.EQ.3) THEN
29323 C...Calculate limits on cos(theta-hat)
29324         YST=VINT(22)
29325 C...0) due to definition
29326         CTNMN0=-1D0
29327         CTNMX0=0D0
29328         CTPMN0=0D0
29329         CTPMX0=1D0
29330 C...1) due to explicit limits
29331         CTNMN1=MIN(0D0,CKIN(27))
29332         CTNMX1=MIN(0D0,CKIN(28))
29333         CTPMN1=MAX(0D0,CKIN(27))
29334         CTPMX1=MAX(0D0,CKIN(28))
29335 C...2) due to limits on pT-hat
29336         CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
29337         CTPMX2=-CTNMN2
29338         CTNMX2=0D0
29339         CTPMN2=0D0
29340         IF(CKIN(4).GE.0D0) THEN
29341           CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
29342      &    (BE34**2*TAU*VINT(2))))
29343           CTPMN2=-CTNMX2
29344         ENDIF
29345 C...3) due to limits on y-large and y-small
29346         CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
29347      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
29348         CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
29349      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
29350         CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
29351      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
29352         CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
29353      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
29354 C...4) due to limits on that
29355         CTNMN4=-1D0
29356         CTNMX4=0D0
29357         CTPMN4=0D0
29358         CTPMX4=1D0
29359         SH=TAU*VINT(2)
29360         IF(CKIN(35).GT.0D0) THEN
29361           CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
29362           IF(CTLIM.GT.0D0) THEN
29363             CTPMX4=CTLIM
29364           ELSE
29365             CTPMX4=0D0
29366             CTNMX4=CTLIM
29367           ENDIF
29368         ENDIF
29369         IF(CKIN(36).GT.0D0) THEN
29370           CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
29371           IF(CTLIM.LT.0D0) THEN
29372             CTNMN4=CTLIM
29373           ELSE
29374             CTNMN4=0D0
29375             CTPMN4=CTLIM
29376           ENDIF
29377         ENDIF
29378 C...5) due to limits on uhat
29379         CTNMN5=-1D0
29380         CTNMX5=0D0
29381         CTPMN5=0D0
29382         CTPMX5=1D0
29383         IF(CKIN(37).GT.0D0) THEN
29384           CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
29385           IF(CTLIM.LT.0D0) THEN
29386             CTNMN5=CTLIM
29387           ELSE
29388             CTNMN5=0D0
29389             CTPMN5=CTLIM
29390           ENDIF
29391         ENDIF
29392         IF(CKIN(38).GT.0D0) THEN
29393           CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
29394           IF(CTLIM.GT.0D0) THEN
29395             CTPMX5=CTLIM
29396           ELSE
29397             CTPMX5=0D0
29398             CTNMX5=CTLIM
29399           ENDIF
29400         ENDIF
29401  
29402 C...Net effect of all separate limits.
29403         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
29404         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
29405         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
29406         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
29407         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
29408 
29409         IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
29410         IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
29411 
29412       ELSEIF(ILIM.EQ.4) THEN
29413 C...Calculate limits on tau'
29414 C...0) due to kinematics
29415         TAPMN0=TAU
29416         IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
29417           PQRAT=(VINT(201)+VINT(206))/VINT(1)
29418           TAPMN0=(SQRT(TAU)+PQRAT)**2
29419         ENDIF
29420         TAPMX0=1D0
29421 C...1) due to explicit limits
29422         TAPMN1=CKIN(31)**2/VINT(2)
29423         TAPMX1=1D0
29424         IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
29425  
29426 C...Net effect of all separate limits.
29427         VINT(16)=MAX(TAPMN0,TAPMN1)
29428         VINT(36)=MIN(TAPMX0,TAPMX1)
29429         IF(MINT(47).EQ.1) THEN
29430           VINT(16)=1D0-1D-9
29431           VINT(36)=1D0+1D-9
29432         ELSEIF(MINT(47).EQ.5) THEN
29433           VINT(36)=MIN(VINT(36),1D0-2D-10)
29434         ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
29435           VINT(36)=MIN(VINT(36),1D0-1D-10)
29436         ENDIF
29437         IF(VINT(36).LE.VINT(16)) MINT(51)=1
29438  
29439       ENDIF
29440       RETURN
29441  
29442 C...Special case for low-pT and multiple interactions:
29443 C...effective kinematical limits for tau, y*, cos(theta-hat).
29444   100 IF(ILIM.EQ.0) THEN
29445       ELSEIF(ILIM.EQ.1) THEN
29446         IF(MSTP(82).LE.1) THEN
29447           VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29448      &    VINT(2)
29449         ELSE
29450           VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
29451         ENDIF
29452         VINT(31)=1D0
29453       ELSEIF(ILIM.EQ.2) THEN
29454         VINT(12)=0.5D0*LOG(VINT(21))
29455         VINT(32)=-VINT(12)
29456       ELSEIF(ILIM.EQ.3) THEN
29457         IF(MSTP(82).LE.1) THEN
29458           ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29459      &    (VINT(21)*VINT(2))
29460         ELSE
29461           ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
29462      &    (VINT(21)*VINT(2))
29463         ENDIF
29464         VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
29465         VINT(33)=0D0
29466         VINT(14)=0D0
29467         VINT(34)=-VINT(13)
29468       ENDIF
29469  
29470       RETURN
29471       END
29472  
29473 C*********************************************************************
29474  
29475 C...PYKMAP
29476 C...Maps a uniform distribution into a distribution of a kinematical
29477 C...variable according to one of the possibilities allowed. It is
29478 C...assumed that kinematical limits have been set by a PYKLIM call.
29479  
29480       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
29481  
29482 C...Double precision and integer declarations.
29483       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29484       IMPLICIT INTEGER(I-N)
29485       INTEGER PYK,PYCHGE,PYCOMP
29486 C...Commonblocks.
29487       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29488       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29489       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29490       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29491       COMMON/PYINT1/MINT(400),VINT(400)
29492       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29493       SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
29494  
29495 C...Convert VVAR to tau variable.
29496       ISUB=MINT(1)
29497       ISTSB=ISET(ISUB)
29498       IF(IVAR.EQ.1) THEN
29499         TAUMIN=VINT(11)
29500         TAUMAX=VINT(31)
29501         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
29502           TAURE=VINT(73)
29503           GAMRE=VINT(74)
29504         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
29505           TAURE=VINT(75)
29506           GAMRE=VINT(76)
29507         ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
29508           TAURE=VINT(77)
29509           GAMRE=VINT(78)
29510         ENDIF
29511         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29512           TAU=1D0
29513         ELSEIF(MVAR.EQ.1) THEN
29514           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
29515         ELSEIF(MVAR.EQ.2) THEN
29516           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
29517         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
29518           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
29519           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
29520         ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
29521           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
29522           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
29523           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
29524         ELSEIF(MINT(47).EQ.5) THEN
29525           AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
29526           ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
29527           TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29528         ELSE
29529           AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
29530           ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
29531           TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29532         ENDIF
29533         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
29534  
29535 C...Convert VVAR to y* variable.
29536       ELSEIF(IVAR.EQ.2) THEN
29537         YSTMIN=VINT(12)
29538         YSTMAX=VINT(32)
29539         TAUE=VINT(21)
29540         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29541         IF(MINT(47).EQ.1) THEN
29542           YST=0D0
29543         ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29544           YST=-0.5D0*LOG(TAUE)
29545         ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29546           YST=0.5D0*LOG(TAUE)
29547         ELSEIF(MVAR.EQ.1) THEN
29548           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
29549         ELSEIF(MVAR.EQ.2) THEN
29550           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
29551         ELSEIF(MVAR.EQ.3) THEN
29552           AUPP=ATAN(EXP(YSTMAX))
29553           ALOW=ATAN(EXP(YSTMIN))
29554           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
29555         ELSEIF(MVAR.EQ.4) THEN
29556           YST0=-0.5D0*LOG(TAUE)
29557           AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
29558           ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29559           YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
29560         ELSE
29561           YST0=-0.5D0*LOG(TAUE)
29562           AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29563           ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
29564           YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
29565         ENDIF
29566         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
29567  
29568 C...Convert VVAR to cos(theta-hat) variable.
29569       ELSEIF(IVAR.EQ.3) THEN
29570         RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
29571         RSQM=1D0+RM34
29572         IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29573      &  RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29574         CTNMIN=VINT(13)
29575         CTNMAX=VINT(33)
29576         CTPMIN=VINT(14)
29577         CTPMAX=VINT(34)
29578         IF(MVAR.EQ.1) THEN
29579           ANEG=CTNMAX-CTNMIN
29580           APOS=CTPMAX-CTPMIN
29581           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29582             VCTN=VVAR*(ANEG+APOS)/ANEG
29583             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
29584           ELSE
29585             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29586             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
29587           ENDIF
29588         ELSEIF(MVAR.EQ.2) THEN
29589           RMNMIN=MAX(RM34,RSQM-CTNMIN)
29590           RMNMAX=MAX(RM34,RSQM-CTNMAX)
29591           RMPMIN=MAX(RM34,RSQM-CTPMIN)
29592           RMPMAX=MAX(RM34,RSQM-CTPMAX)
29593           ANEG=LOG(RMNMIN/RMNMAX)
29594           APOS=LOG(RMPMIN/RMPMAX)
29595           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29596             VCTN=VVAR*(ANEG+APOS)/ANEG
29597             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
29598           ELSE
29599             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29600             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
29601           ENDIF
29602         ELSEIF(MVAR.EQ.3) THEN
29603           RMNMIN=MAX(RM34,RSQM+CTNMIN)
29604           RMNMAX=MAX(RM34,RSQM+CTNMAX)
29605           RMPMIN=MAX(RM34,RSQM+CTPMIN)
29606           RMPMAX=MAX(RM34,RSQM+CTPMAX)
29607           ANEG=LOG(RMNMAX/RMNMIN)
29608           APOS=LOG(RMPMAX/RMPMIN)
29609           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29610             VCTN=VVAR*(ANEG+APOS)/ANEG
29611             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
29612           ELSE
29613             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29614             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
29615           ENDIF
29616         ELSEIF(MVAR.EQ.4) THEN
29617           RMNMIN=MAX(RM34,RSQM-CTNMIN)
29618           RMNMAX=MAX(RM34,RSQM-CTNMAX)
29619           RMPMIN=MAX(RM34,RSQM-CTPMIN)
29620           RMPMAX=MAX(RM34,RSQM-CTPMAX)
29621           ANEG=1D0/RMNMAX-1D0/RMNMIN
29622           APOS=1D0/RMPMAX-1D0/RMPMIN
29623           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29624             VCTN=VVAR*(ANEG+APOS)/ANEG
29625             CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
29626           ELSE
29627             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29628             CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
29629           ENDIF
29630         ELSEIF(MVAR.EQ.5) THEN
29631           RMNMIN=MAX(RM34,RSQM+CTNMIN)
29632           RMNMAX=MAX(RM34,RSQM+CTNMAX)
29633           RMPMIN=MAX(RM34,RSQM+CTPMIN)
29634           RMPMAX=MAX(RM34,RSQM+CTPMAX)
29635           ANEG=1D0/RMNMIN-1D0/RMNMAX
29636           APOS=1D0/RMPMIN-1D0/RMPMAX
29637           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29638             VCTN=VVAR*(ANEG+APOS)/ANEG
29639             CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
29640           ELSE
29641             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29642             CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
29643           ENDIF
29644         ENDIF
29645         IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29646         IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29647         VINT(23)=CTH
29648  
29649 C...Convert VVAR to tau' variable.
29650       ELSEIF(IVAR.EQ.4) THEN
29651         TAU=VINT(21)
29652         TAUPMN=VINT(16)
29653         TAUPMX=VINT(36)
29654         IF(MINT(47).EQ.1) THEN
29655           TAUP=1D0
29656         ELSEIF(MVAR.EQ.1) THEN
29657           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29658         ELSEIF(MVAR.EQ.2) THEN
29659           AUPP=(1D0-TAU/TAUPMX)**4
29660           ALOW=(1D0-TAU/TAUPMN)**4
29661           TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29662         ELSEIF(MINT(47).EQ.5) THEN
29663           AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29664           ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29665           TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29666         ELSE
29667           AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29668           ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29669           TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29670         ENDIF
29671         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29672  
29673 C...Selection of extra variables needed in 2 -> 3 process:
29674 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29675 C...Since no options are available, the functions of PYKLIM
29676 C...and PYKMAP are joint for these choices.
29677       ELSEIF(IVAR.EQ.5) THEN
29678  
29679 C...Read out total energy and particle masses.
29680         MINT(51)=0
29681         MPTPK=1
29682         IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29683      &  .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29684      &  MPTPK=2
29685         SHP=VINT(26)*VINT(2)
29686         SHPR=SQRT(SHP)
29687         PM1=VINT(201)
29688         PM2=VINT(206)
29689         PM3=SQRT(VINT(21))*VINT(1)
29690         IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29691           MINT(51)=1
29692           RETURN
29693         ENDIF
29694         PMRS1=VINT(204)**2
29695         PMRS2=VINT(209)**2
29696  
29697 C...Specify coefficients of pT choice; upper and lower limits.
29698         IF(MPTPK.EQ.1) THEN
29699           HWT1=0.4D0
29700           HWT2=0.4D0
29701         ELSE
29702           HWT1=0.05D0
29703           HWT2=0.05D0
29704         ENDIF
29705         HWT3=1D0-HWT1-HWT2
29706         PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29707      &  (4D0*SHP)
29708         IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29709         PTSMN1=CKIN(51)**2
29710         PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29711      &  (4D0*SHP)
29712         IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29713         PTSMN2=CKIN(53)**2
29714  
29715 C...Select transverse momenta according to
29716 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29717         HMX=PMRS1+PTSMX1
29718         HMN=PMRS1+PTSMN1
29719         IF(HMX.LT.1.0001D0*HMN) THEN
29720           MINT(51)=1
29721           RETURN
29722         ENDIF
29723         HDE=PTSMX1-PTSMN1
29724         RPT=PYR(0)
29725         IF(RPT.LT.HWT1) THEN
29726           PTS1=PTSMN1+PYR(0)*HDE
29727         ELSEIF(RPT.LT.HWT1+HWT2) THEN
29728           PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29729         ELSE
29730           PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29731         ENDIF
29732         WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29733      &  HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29734         HMX=PMRS2+PTSMX2
29735         HMN=PMRS2+PTSMN2
29736         IF(HMX.LT.1.0001D0*HMN) THEN
29737           MINT(51)=1
29738           RETURN
29739         ENDIF
29740         HDE=PTSMX2-PTSMN2
29741         RPT=PYR(0)
29742         IF(RPT.LT.HWT1) THEN
29743           PTS2=PTSMN2+PYR(0)*HDE
29744         ELSEIF(RPT.LT.HWT1+HWT2) THEN
29745           PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29746         ELSE
29747           PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29748         ENDIF
29749         WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29750      &  HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29751  
29752 C...Select azimuthal angles and check pT choice.
29753         PHI1=PARU(2)*PYR(0)
29754         PHI2=PARU(2)*PYR(0)
29755         PHIR=PHI2-PHI1
29756         PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29757         IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29758      &  CKIN(56)**2)) THEN
29759           MINT(51)=1
29760           RETURN
29761         ENDIF
29762  
29763 C...Calculate transverse masses and check phase space not closed.
29764         PMS1=PM1**2+PTS1
29765         PMS2=PM2**2+PTS2
29766         PMS3=PM3**2+PTS3
29767         PMT1=SQRT(PMS1)
29768         PMT2=SQRT(PMS2)
29769         PMT3=SQRT(PMS3)
29770         PM12=(PMT1+PMT2)**2
29771         IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29772           MINT(51)=1
29773           RETURN
29774         ENDIF
29775  
29776 C...Select rapidity for particle 3 and check phase space not closed.
29777         Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29778      &  4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29779         IF(Y3MAX.LT.1D-6) THEN
29780           MINT(51)=1
29781           RETURN
29782         ENDIF
29783         Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29784         PZ3=PMT3*SINH(Y3)
29785         PE3=PMT3*COSH(Y3)
29786  
29787 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29788         PZ12=-PZ3
29789         PE12=SHPR-PE3
29790         PMS12=PE12**2-PZ12**2
29791         SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29792         IF(SQL12.LT.1D-6*SHP) THEN
29793           MINT(51)=1
29794           RETURN
29795         ENDIF
29796         PMM1=PMS12+PMS1-PMS2
29797         PMM2=PMS12+PMS2-PMS1
29798         TFAC=-SHPR/(2D0*PMS12)
29799         T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29800         T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29801         T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29802         T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29803  
29804 C...Construct relative mirror weights and make choice.
29805         IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29806           WTPU=1D0
29807           WTNU=1D0
29808         ELSE
29809           WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29810           WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29811         ENDIF
29812         WTP=WTPU/(WTPU+WTNU)
29813         WTN=WTNU/(WTPU+WTNU)
29814         EPS=1D0
29815         IF(WTN.GT.PYR(0)) EPS=-1D0
29816  
29817 C...Store result of variable choice and associated weights.
29818         VINT(202)=PTS1
29819         VINT(207)=PTS2
29820         VINT(203)=PHI1
29821         VINT(208)=PHI2
29822         VINT(205)=WTPTS1
29823         VINT(210)=WTPTS2
29824         VINT(211)=Y3
29825         VINT(212)=Y3MAX
29826         VINT(213)=EPS
29827         IF(EPS.GT.0D0) THEN
29828           VINT(214)=1D0/WTP
29829           VINT(215)=T1P
29830           VINT(216)=T2P
29831         ELSE
29832           VINT(214)=1D0/WTN
29833           VINT(215)=T1N
29834           VINT(216)=T2N
29835         ENDIF
29836         VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29837         VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29838         VINT(219)=0.5D0*(PMS12-PTS3)
29839         VINT(220)=SQL12
29840       ENDIF
29841  
29842       RETURN
29843       END
29844  
29845 C***********************************************************************
29846  
29847 C...PYSIGH
29848 C...Differential matrix elements for all included subprocesses
29849 C...Note that what is coded is (disregarding the COMFAC factor)
29850 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29851 C...when d(sigma-hat) is given in the zero-width limit, the delta
29852 C...function in tau is replaced by a (modified) Breit-Wigner:
29853 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29854 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29855 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29856 C...i.e., dimensionless quantities
29857 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29858 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29859 C...(2pi)^4 delta^4(P - sum p_i)
29860 C...COMFAC contains the factor pi/s (or equivalent) and
29861 C...the conversion factor from GeV^-2 to mb
29862  
29863       SUBROUTINE PYSIGH(NCHN,SIGS)
29864  
29865 C...Double precision and integer declarations
29866       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29867       IMPLICIT INTEGER(I-N)
29868       INTEGER PYK,PYCHGE,PYCOMP
29869 C...Parameter statement to help give large particle numbers.
29870       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29871      &KEXCIT=4000000,KDIMEN=5000000)
29872 C...Commonblocks
29873       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29874       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29875       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29876       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29877       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29878       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29879       COMMON/PYINT1/MINT(400),VINT(400)
29880       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29881       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29882       COMMON/PYINT4/MWID(500),WIDS(500,5)
29883       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29884       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29885       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29886       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29887      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29888       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29889       COMMON/PYPUED/IUED(0:99),RUED(0:99)
29890       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29891      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29892      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29893      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29894       COMMON/PYTCCO/COEFX(194:380,2)
29895       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29896      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29897      &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29898 C...Local arrays and complex variables
29899       DIMENSION XPQ(-25:25)
29900  
29901 C...Map of processes onto which routine to call
29902 C...in order to evaluate cross section:
29903 C...0 = not implemented;
29904 C...1 = standard QCD (including photons);
29905 C...2 = heavy flavours;
29906 C...3 = W/Z;
29907 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29908 C...5 = SUSY;
29909 C...6 = Technicolor;
29910 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29911 C...8 = Universal Extra Dimensions
29912       DIMENSION MAPPR(500)
29913       DATA (MAPPR(I),I=1,180)/
29914      &    3,  3,  4,  0,  4,  0,  0,  4,  0,  1,
29915      1    1,  1,  1,  1,  3,  3,  0,  1,  3,  3,
29916      2    0,  3,  3,  4,  3,  4,  0,  1,  1,  3,
29917      3    3,  4,  1,  1,  3,  3,  0,  0,  0,  0,
29918      4    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29919      5    0,  0,  1,  1,  0,  0,  0,  1,  0,  0,
29920      6    0,  0,  0,  0,  0,  0,  0,  1,  3,  3,
29921      7    4,  4,  4,  0,  0,  4,  4,  0,  0,  1,
29922      8    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
29923      9    1,  1,  1,  1,  1,  1,  0,  0,  1,  0,
29924      &    0,  4,  4,  2,  2,  2,  2,  2,  0,  4,
29925      1    4,  4,  4,  1,  1,  0,  0,  0,  0,  0,
29926      2    4,  4,  4,  4,  0,  0,  0,  0,  0,  0,
29927      3    1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
29928      4    7,  7,  4,  7,  7,  7,  7,  7,  6,  0,
29929      5    4,  4,  4,  0,  0,  4,  4,  4,  0,  0,
29930      6    4,  7,  7,  7,  6,  6,  7,  7,  7,  0,
29931      7    4,  4,  4,  4,  0,  4,  4,  4,  4,  0/
29932       DATA (MAPPR(I),I=181,500)/
29933      8    4,  4,  4,  4,  4,  4,  4,  4,  4,  4,
29934      9    6,  6,  6,  6,  6,  0,  0,  0,  0,  0,
29935      &    100*5,
29936      &    5,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29937      &    8,  8,  8,  8,  8,  8,  8,  8,  8,  0,
29938      1    20*0,
29939      4    7,  7,  7,  7,  7,  7,  7,  7,  7,  7,
29940      5    7,  7,  7,  7,  0,  0,  0,  0,  0,  0,
29941      6    6,  6,  6,  6,  6,  6,  6,  6,  0,  6,
29942      7    6,  6,  6,  6,  6,  6,  6,  6,  6,  6,
29943      8    6,  6,  6,  6,  6,  6,  6,  6,  0,  0,
29944      9    7,  7,  7,  7,  7,  0,  0,  0,  0,  0,
29945      &    4,  4,  18*0,
29946      2    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
29947      3    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
29948      4     20*0,
29949      6    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
29950      7    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
29951      8    7,  7,  18*0/ 
29952  
29953 C...Reset number of channels and cross-section
29954       NCHN=0
29955       SIGS=0D0
29956  
29957 C...Read process to consider.
29958       ISUB=MINT(1)
29959       ISUBSV=ISUB
29960       MAP=MAPPR(ISUB)
29961  
29962 C...Read kinematical variables and limits
29963       ISTSB=ISET(ISUBSV)
29964       TAUMIN=VINT(11)
29965       YSTMIN=VINT(12)
29966       CTNMIN=VINT(13)
29967       CTPMIN=VINT(14)
29968       TAUPMN=VINT(16)
29969       TAU=VINT(21)
29970       YST=VINT(22)
29971       CTH=VINT(23)
29972       XT2=VINT(25)
29973       TAUP=VINT(26)
29974       TAUMAX=VINT(31)
29975       YSTMAX=VINT(32)
29976       CTNMAX=VINT(33)
29977       CTPMAX=VINT(34)
29978       TAUPMX=VINT(36)
29979  
29980 C...Derive kinematical quantities
29981       TAUE=TAU
29982       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29983       X(1)=SQRT(TAUE)*EXP(YST)
29984       X(2)=SQRT(TAUE)*EXP(-YST)
29985       IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29986         IF(X(1).GT.1D0-1D-7) RETURN
29987       ELSEIF(MINT(45).EQ.3) THEN
29988         X(1)=MIN(1D0-1.1D-10,X(1))
29989       ENDIF
29990       IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29991         IF(X(2).GT.1D0-1D-7) RETURN
29992       ELSEIF(MINT(46).EQ.3) THEN
29993         X(2)=MIN(1D0-1.1D-10,X(2))
29994       ENDIF
29995       SH=MAX(1D0,TAU*VINT(2))
29996       SQM3=VINT(63)
29997       SQM4=VINT(64)
29998       RM3=SQM3/SH
29999       RM4=SQM4/SH
30000       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
30001       RPTS=4D0*VINT(71)**2/SH
30002       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
30003       RM34=MAX(1D-20,2D0*RM3*RM4)
30004       RSQM=1D0+RM34
30005       IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
30006      &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
30007       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
30008       IF(ISTSB.EQ.0) THEN
30009         TH=VINT(45)
30010         UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
30011         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
30012       ELSE
30013 C...Kinematics with incoming masses tricky: now depends on how
30014 C...subprocess has been set up w.r.t. order of incoming partons.
30015         RM1=0D0
30016         IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
30017         RM2=0D0
30018         IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
30019         IF(ISUB.EQ.35) THEN
30020           RM2=MIN(RM1,RM2)
30021           RM1=0D0
30022         ENDIF
30023         BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
30024         TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
30025         TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
30026      &  BE12*BE34*CTH)
30027         UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
30028      &  BE12*BE34*CTH)
30029         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
30030       ENDIF
30031       SHR=SQRT(SH)
30032       SH2=SH**2
30033       TH2=TH**2
30034       UH2=UH**2
30035  
30036 C...Choice of Q2 scale for hard process (e.g. alpha_s).
30037       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
30038         Q2=SH
30039       ELSEIF(ISTSB.EQ.8) THEN
30040         IF(MINT(107).EQ.4) Q2=VINT(307)
30041         IF(MINT(108).EQ.4) Q2=VINT(308)
30042       ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
30043         Q2IN1=0D0
30044         IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
30045         Q2IN2=0D0
30046         IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
30047         IF(MSTP(32).EQ.1) THEN
30048           Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
30049         ELSEIF(MSTP(32).EQ.2) THEN
30050           Q2=SQPTH+0.5D0*(SQM3+SQM4)
30051         ELSEIF(MSTP(32).EQ.3) THEN
30052           Q2=MIN(-TH,-UH)
30053         ELSEIF(MSTP(32).EQ.4) THEN
30054           Q2=SH
30055         ELSEIF(MSTP(32).EQ.5) THEN
30056           Q2=-TH
30057         ELSEIF(MSTP(32).EQ.6) THEN
30058           XSF1=X(1)
30059           IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
30060           XSF2=X(2)
30061           IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
30062           Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
30063      &    (SQPTH+0.5D0*(SQM3+SQM4))
30064         ELSEIF(MSTP(32).EQ.7) THEN
30065           Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
30066         ELSEIF(MSTP(32).EQ.8) THEN
30067           Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
30068         ELSEIF(MSTP(32).EQ.9) THEN
30069           Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
30070         ELSEIF(MSTP(32).EQ.10) THEN
30071           Q2=VINT(2)
30072 C..Begin JA 040914
30073         ELSEIF(MSTP(32).EQ.11) THEN
30074           Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
30075         ELSEIF(MSTP(32).EQ.12) THEN
30076           Q2=PARP(193)
30077 C..End JA
30078         ELSEIF(MSTP(32).EQ.13) THEN
30079           Q2=SQPTH
30080         ENDIF
30081         IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
30082         IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
30083      &  (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
30084       ENDIF
30085  
30086 C...Choice of Q2 scale for parton densities.
30087       Q2SF=Q2
30088 C..Begin JA 040914
30089       IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
30090      &     .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
30091      &     Q2=PARP(194)
30092 C..End JA
30093       IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30094         Q2SF=PMAS(23,1)**2
30095         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
30096      &  ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2 
30097         IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
30098         IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
30099      &  ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
30100           Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
30101           IF(MSTP(39).EQ.2) Q2SF=
30102      &         MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
30103           IF(MSTP(39).EQ.3) Q2SF=SH
30104           IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
30105           IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
30106 C..Begin JA 040914
30107           IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
30108           IF(MSTP(39).EQ.7) Q2SF=
30109      &         (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
30110           IF(MSTP(39).EQ.8) Q2SF=PARP(193)
30111 C..End JA
30112         ENDIF
30113       ENDIF
30114       IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
30115  
30116       Q2PS=Q2SF
30117       Q2SF=Q2SF*PARP(34)
30118       IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
30119       IF(MSTP(69).GE.2) Q2SF=VINT(2)
30120  
30121 C...Identify to which class(es) subprocess belongs
30122       ISMECR=0
30123       ISQCD=0
30124       ISJETS=0
30125       IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
30126      &     ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
30127      &     ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
30128      &     ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
30129       IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
30130      &     ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
30131       IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
30132       IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
30133       IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
30134       IF (ISTSB.EQ.9) ISQCD=1
30135       IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
30136      &     (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
30137      &     ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
30138      &     ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
30139      &     (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
30140      &     ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
30141      &     ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
30142      &     (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
30143 C...WBF is special case of ISJETS
30144       IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
30145      &    (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
30146      &    ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
30147      &    (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
30148      &    ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
30149      &    ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
30150      &    ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
30151      &    ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
30152      &    ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
30153 C...Some processes with photons also belong here.
30154       IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
30155      &     (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
30156      &     ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
30157      &     ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
30158      &     (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
30159      &     (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
30160 
30161 C...Choice of Q2 scale for parton-shower activity.
30162       IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
30163      &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
30164         XBJ=X(2)
30165         IF(MINT(43).EQ.3) XBJ=X(1)
30166         IF(MSTP(22).EQ.1) THEN
30167           Q2PS=-TH
30168         ELSEIF(MSTP(22).EQ.2) THEN
30169           Q2PS=((1D0-XBJ)/XBJ)*(-TH)
30170         ELSEIF(MSTP(22).EQ.3) THEN
30171           Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
30172         ELSE
30173           Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
30174         ENDIF
30175       ENDIF
30176 C...For multiple interactions, start from scale defined above
30177 C...For all other QCD or "+jets"-type events, start shower from pThard.
30178       IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
30179       IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
30180 C...Max shower scale = s for ME corrected processes.
30181 C...(pT-ordering: max pT2 is s/4)
30182         Q2PS=VINT(2)
30183         IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30184       ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
30185 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
30186 C...(pT-ordering: max pT2 is s/4)
30187         Q2PS=VINT(2)
30188         IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30189       ENDIF
30190       IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
30191 
30192 C...Elastic and diffractive events not associated with scales so set 0.
30193       IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
30194         Q2SF=0D0
30195         Q2PS=0D0
30196       ENDIF
30197  
30198 C...Store derived kinematical quantities
30199       VINT(41)=X(1)
30200       VINT(42)=X(2)
30201       VINT(44)=SH
30202       VINT(43)=SQRT(SH)
30203       VINT(45)=TH
30204       VINT(46)=UH
30205       IF(ISTSB.NE.8) VINT(48)=SQPTH
30206       IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
30207       VINT(50)=TAUP*VINT(2)
30208       VINT(49)=SQRT(MAX(0D0,VINT(50)))
30209       VINT(52)=Q2
30210       VINT(51)=SQRT(Q2)
30211       VINT(54)=Q2SF
30212       VINT(53)=SQRT(Q2SF)
30213       VINT(56)=Q2PS
30214       VINT(55)=SQRT(Q2PS)
30215  
30216 C...Set starting scale for multiple interactions
30217       IF (ISUBSV.EQ.95) THEN
30218         XT2GMX=0D0
30219       ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
30220      &      ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
30221      &      ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
30222      &      ISUBSV.NE.96)) THEN
30223 C...All accessible phase space allowed.
30224         XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
30225       ELSE
30226 C...Scale of hard process sets limit.
30227 C...2 -> 1. Limit is tau = x1*x2.
30228 C...2 -> 2. Limit is XT2 for hard process + FS masses.
30229 C...2 -> n > 2. Limit is tau' = tau of outer process.
30230         XT2GMX=VINT(25)
30231         IF(ISTSB.EQ.1) XT2GMX=VINT(21)
30232         IF(ISTSB.EQ.2)
30233      &      XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
30234         IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
30235       ENDIF
30236       VINT(62)=0.25D0*XT2GMX*VINT(2)
30237       VINT(61)=SQRT(MAX(0D0,VINT(62)))
30238  
30239 C...Calculate parton distributions
30240       IF(ISTSB.LE.0) GOTO 160
30241       IF(MINT(47).GE.2) THEN
30242         DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
30243           XSF=X(I)
30244           IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
30245           IF(ISUB.EQ.99) THEN
30246             IF(MINT(140+I).EQ.0) THEN
30247               XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
30248             ELSE
30249               XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
30250             ENDIF
30251             VINT(40+I)=XSF
30252             Q2SF=VINT(309-I)
30253           ENDIF
30254           MINT(105)=MINT(102+I)
30255           MINT(109)=MINT(106+I)
30256           VINT(120)=VINT(2+I)
30257 C...Default is to use standard PDFs, but for interactions after the first
30258 C...in the new multiple-parton-interactions framework, set which side to
30259 C...evaluate the MPI-modified PDFs on.
30260           MINT(30)=0
30261           IF (MINT(31).GE.1) MINT(30)=I
30262           IF(MSTP(57).LE.1) THEN
30263             CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
30264           ELSE
30265             CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
30266           ENDIF
30267 C...Safety margin against heavy flavour very close to threshold,
30268 C...e.g. caused by mismatch in c and b masses.
30269           IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
30270             XPQ(4)=0D0
30271             XPQ(-4)=0D0
30272           ENDIF
30273           IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
30274             XPQ(5)=0D0
30275             XPQ(-5)=0D0
30276           ENDIF
30277           DO 100 KFL=-25,25
30278             XSFX(I,KFL)=XPQ(KFL)
30279   100     CONTINUE
30280   110   CONTINUE
30281       ENDIF
30282  
30283 C...Calculate alpha_em, alpha_strong and K-factor
30284       XW=PARU(102)
30285       XWV=XW
30286       IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
30287      &1D0-(PMAS(24,1)/PMAS(23,1))**2
30288       XW1=1D0-XW
30289       XWC=1D0/(16D0*XW*XW1)
30290       AEM=PYALEM(Q2)
30291       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
30292       IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
30293       FACK=1D0
30294       FACA=1D0
30295       IF(MSTP(33).EQ.1) THEN
30296         FACK=PARP(31)
30297       ELSEIF(MSTP(33).EQ.2) THEN
30298         FACK=PARP(31)
30299         FACA=PARP(32)/PARP(31)
30300       ELSEIF(MSTP(33).EQ.3) THEN
30301         Q2AS=PARP(33)*Q2
30302         IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
30303      &  PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
30304         AS=PYALPS(Q2AS)
30305 C...PS (12 Feb 2010)
30306 C...New options MSTP(33) = 10 and 11
30307 C...  10: use K-factor = PARP(32) only for process 96 (MPI)
30308 C...  11: as for 10, but also use K-factor = PARP(31) for other procs
30309       ELSEIF(MSTP(33).GE.10) THEN
30310         IF (ISUB.EQ.96) THEN
30311           FACK = PARP(32)
30312         ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
30313           FACK = PARP(31)
30314         ENDIF
30315       ENDIF
30316       VINT(138)=1D0
30317       VINT(57)=AEM
30318       VINT(58)=AS
30319  
30320 C...Set flags for allowed reacting partons/leptons
30321       DO 140 I=1,2
30322         DO 120 J=-25,25
30323           KFAC(I,J)=0
30324   120   CONTINUE
30325         IF(MINT(44+I).EQ.1) THEN
30326           KFAC(I,MINT(10+I))=1
30327         ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
30328           KFAC(I,MINT(10+I))=1
30329           KFAC(I,22)=1
30330           KFAC(I,24)=1
30331           KFAC(I,-24)=1
30332         ELSE
30333           DO 130 J=-25,25
30334             KFAC(I,J)=KFIN(I,J)
30335             IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
30336             IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
30337   130     CONTINUE
30338         ENDIF
30339   140 CONTINUE
30340  
30341 C...Lower and upper limit for fermion flavour loops
30342       MMIN1=0
30343       MMAX1=0
30344       MMIN2=0
30345       MMAX2=0
30346       DO 150 J=-20,20
30347         IF(KFAC(1,-J).EQ.1) MMIN1=-J
30348         IF(KFAC(1,J).EQ.1) MMAX1=J
30349         IF(KFAC(2,-J).EQ.1) MMIN2=-J
30350         IF(KFAC(2,J).EQ.1) MMAX2=J
30351   150 CONTINUE
30352       MMINA=MIN(MMIN1,MMIN2)
30353       MMAXA=MAX(MMAX1,MMAX2)
30354  
30355 C...Common resonance mass and width combinations
30356       SQMZ=PMAS(23,1)**2
30357       SQMW=PMAS(24,1)**2
30358       GMMZ=PMAS(23,1)*PMAS(23,2)
30359       GMMW=PMAS(24,1)*PMAS(24,2)
30360  
30361 C...Polarization factors...implemented so far for W+W-(25)
30362       POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
30363       POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
30364       POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
30365       POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
30366  
30367 C...Phase space integral in tau
30368       COMFAC=PARU(1)*PARU(5)/VINT(2)
30369       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
30370       IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
30371      &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
30372         ATAU1=LOG(TAUMAX/TAUMIN)
30373         ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
30374         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
30375         IF(MINT(72).GE.1) THEN
30376           TAUR1=VINT(73)
30377           GAMR1=VINT(74)
30378           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
30379           ATAU3=ATAUD/TAUR1
30380           IF(ATAUD.GT.1D-10) H1=H1+
30381      &    (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
30382           ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
30383           ATAU4=ATAUD/GAMR1
30384           IF(ATAUD.GT.1D-10) H1=H1+
30385      &    (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
30386         ENDIF
30387         IF(MINT(72).GE.2) THEN
30388           TAUR2=VINT(75)
30389           GAMR2=VINT(76)
30390           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
30391           ATAU5=ATAUD/TAUR2
30392           IF(ATAUD.GT.1D-10) H1=H1+
30393      &    (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
30394           ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
30395           ATAU6=ATAUD/GAMR2
30396           IF(ATAUD.GT.1D-10) H1=H1+
30397      &    (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
30398         ENDIF
30399         IF(MINT(72).EQ.3) THEN
30400           TAUR3=VINT(77)
30401           GAMR3=VINT(78)
30402           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
30403           ATAU50=ATAUD/TAUR3
30404           IF(ATAUD.GT.1D-10) H1=H1+
30405      &    (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
30406           ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
30407           ATAU60=ATAUD/GAMR3
30408           IF(ATAUD.GT.1D-10) H1=H1+
30409      &    (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
30410         ENDIF
30411         IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30412           ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
30413           IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30414      &    MAX(2D-10,1D0-TAU)
30415         ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30416           ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
30417           IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30418      &    MAX(1D-10,1D0-TAU)
30419         ENDIF
30420         COMFAC=COMFAC*ATAU1/(TAU*H1)
30421       ENDIF
30422  
30423 C...Phase space integral in y*
30424       IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
30425      &THEN
30426         AYST0=YSTMAX-YSTMIN
30427         IF(AYST0.LT.1D-10) THEN
30428           COMFAC=0D0
30429         ELSE
30430           AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30431           AYST2=AYST1
30432           AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30433           H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30434      &    (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30435      &    (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30436           IF(MINT(45).EQ.3) THEN
30437             YST0=-0.5D0*LOG(TAUE)
30438             AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
30439      &      MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
30440             IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
30441      &      MAX(1D-10,1D0-EXP(YST-YST0))
30442           ENDIF
30443           IF(MINT(46).EQ.3) THEN
30444             YST0=-0.5D0*LOG(TAUE)
30445             AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
30446      &      MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
30447             IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
30448      &      MAX(1D-10,1D0-EXP(-YST-YST0))
30449           ENDIF
30450           COMFAC=COMFAC*AYST0/H2
30451         ENDIF
30452       ENDIF
30453  
30454 C...2 -> 1 processes: reduction in angular part of phase space integral
30455 C...for case of decaying resonance
30456       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
30457       IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
30458         IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
30459           IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
30460      &    KFPR(ISUB,1).EQ.39) THEN
30461             COMFAC=COMFAC*0.5D0*ACTH0
30462           ELSE
30463             COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
30464      &      CTPMAX**3-CTPMIN**3)
30465           ENDIF
30466         ENDIF
30467  
30468 C...2 -> 2 processes: angular part of phase space integral
30469       ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
30470         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
30471      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
30472         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
30473      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
30474         ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
30475      &  1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
30476         ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
30477      &  1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
30478         H3=COEF(ISUBSV,13)+
30479      &  (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
30480      &  (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
30481      &  (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
30482      &  (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
30483         COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
30484  
30485 C...2 -> 2 processes: take into account final state Breit-Wigners
30486         COMFAC=COMFAC*VINT(80)
30487       ENDIF
30488  
30489 C...2 -> 3, 4 processes: phace space integral in tau'
30490       IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30491         ATAUP1=LOG(TAUPMX/TAUPMN)
30492         ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
30493         H4=COEF(ISUBSV,18)+
30494      &  (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
30495         IF(MINT(47).EQ.5) THEN
30496           ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
30497           H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
30498         ELSEIF(MINT(47).GE.6) THEN
30499           ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
30500           H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
30501         ENDIF
30502         COMFAC=COMFAC*ATAUP1/H4
30503       ENDIF
30504  
30505 C...2 -> 3, 4 processes: effective W/Z parton distributions
30506       IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
30507         IF(1D0-TAU/TAUP.GT.1D-4) THEN
30508           FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
30509         ELSE
30510           FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
30511         ENDIF
30512         COMFAC=COMFAC*FZW
30513       ENDIF
30514  
30515 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
30516       IF(ISTSB.EQ.5) THEN
30517         COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
30518      &  (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
30519       ENDIF
30520  
30521 C...Phase space integral for low-pT and multiple interactions
30522       IF(ISTSB.EQ.9) THEN
30523         COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
30524         ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
30525         ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
30526         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
30527         COMFAC=COMFAC*ATAU1/H1
30528         AYST0=YSTMAX-YSTMIN
30529         AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30530         AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30531         H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30532      &  (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30533      &  (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30534         COMFAC=COMFAC*AYST0/H2
30535         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
30536 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
30537 C...introduced to make cross-section finite for xT2 -> 0
30538         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
30539      &  (1D0+VINT(149)))
30540       ENDIF
30541  
30542 C...Real gamma + gamma: include factor 2 when different nature
30543   160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
30544      &MSTP(14).LE.10) COMFAC=2D0*COMFAC
30545  
30546 C...Extra factors to include the effects of
30547 C...longitudinal resolved photons (but not direct or DIS ones).
30548       DO 170 ISDE=1,2
30549         IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
30550      &  MINT(106+ISDE).LE.3) THEN
30551           VINT(314+ISDE)=1D0
30552           XY=PARP(166+ISDE)
30553           IF(MSTP(16).EQ.0) THEN
30554             IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
30555      &      XY=VINT(304+ISDE)
30556           ELSE
30557             IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
30558      &      XY=VINT(308+ISDE)
30559           ENDIF
30560           Q2GA=VINT(306+ISDE)
30561           IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
30562      &    Q2GA.GT.0D0) THEN
30563             REDUCE=0D0
30564             IF(MSTP(17).EQ.1) THEN
30565               REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
30566             ELSEIF(MSTP(17).EQ.2) THEN
30567               REDUCE=4D0*Q2GA/(Q2+Q2GA)
30568             ELSEIF(MSTP(17).EQ.3) THEN
30569               PMVIRT=PMAS(PYCOMP(113),1)
30570               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30571             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
30572               PMVIRT=PMAS(PYCOMP(113),1)
30573               REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30574             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
30575               PMVIRT=PMAS(PYCOMP(113),1)
30576               REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30577             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
30578               PMVSMN=4D0*PARP(15)**2
30579               PMVSMX=4D0*VINT(154)**2
30580               REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30581               REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
30582      &        (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
30583               REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
30584             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
30585               PMVIRT=PMAS(PYCOMP(113),1)
30586               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30587             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
30588               PMVIRT=PMAS(PYCOMP(113),1)
30589               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30590             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
30591               PMVSMN=4D0*PARP(15)**2
30592               PMVSMX=4D0*VINT(154)**2
30593               REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30594               REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
30595               REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
30596             ENDIF
30597             BEAMAS=PYMASS(11)
30598             IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
30599             FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
30600      &      (1D0-2D0*BEAMAS**2/Q2GA))
30601             VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
30602           ENDIF
30603         ELSE
30604           VINT(314+ISDE)=1D0
30605         ENDIF
30606         COMFAC=COMFAC*VINT(314+ISDE)
30607   170 CONTINUE
30608  
30609 C...Evaluate cross sections - done in separate routines by kind
30610 C...of physics, to keep PYSIGH of sensible size.
30611       IF(MAP.EQ.1) THEN
30612 C...Standard QCD (including photons).
30613         CALL PYSGQC(NCHN,SIGS)
30614       ELSEIF(MAP.EQ.2) THEN
30615 C...Heavy flavours.
30616         CALL PYSGHF(NCHN,SIGS)
30617       ELSEIF(MAP.EQ.3) THEN
30618 C...W/Z.
30619         CALL PYSGWZ(NCHN,SIGS)
30620       ELSEIF(MAP.EQ.4) THEN
30621 C...Higgs (2 doublets; including longitudinal W/Z scattering).
30622         CALL PYSGHG(NCHN,SIGS)
30623       ELSEIF(MAP.EQ.5) THEN
30624 C...SUSY.
30625         CALL PYSGSU(NCHN,SIGS)
30626       ELSEIF(MAP.EQ.6) THEN
30627 C...Technicolor.
30628         CALL PYSGTC(NCHN,SIGS)
30629       ELSEIF(MAP.EQ.7) THEN
30630 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
30631         CALL PYSGEX(NCHN,SIGS)
30632       ELSEIF(MAP.EQ.8) THEN
30633 C... Universal Extra Dimensions
30634         CALL PYXUED(NCHN,SIGS)
30635       ENDIF
30636  
30637 C...Multiply with parton distributions
30638       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
30639         DO 180 ICHN=1,NCHN
30640           IF(MINT(45).GE.2) THEN
30641             KFL1=ISIG(ICHN,1)
30642             SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
30643           ENDIF
30644           IF(MINT(46).GE.2) THEN
30645             KFL2=ISIG(ICHN,2)
30646             SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
30647           ENDIF
30648           SIGS=SIGS+SIGH(ICHN)
30649   180   CONTINUE
30650       ENDIF
30651  
30652       RETURN
30653       END
30654  
30655 C*********************************************************************
30656  
30657 C...PYSGQC
30658 C...Subprocess cross sections for QCD processes,
30659 C...including photons.
30660 C...Auxiliary to PYSIGH.
30661  
30662       SUBROUTINE PYSGQC(NCHN,SIGS)
30663  
30664 C...Double precision and integer declarations
30665       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30666       IMPLICIT INTEGER(I-N)
30667       INTEGER PYK,PYCHGE,PYCOMP
30668 C...Parameter statement to help give large particle numbers.
30669       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30670      &KEXCIT=4000000,KDIMEN=5000000)
30671 C...Commonblocks
30672       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30673       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30674       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30675       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30676       COMMON/PYINT1/MINT(400),VINT(400)
30677       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30678       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30679       COMMON/PYINT4/MWID(500),WIDS(500,5)
30680       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30681       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30682      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30683      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30684      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30685       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30686      &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30687 C...Local arrays
30688       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30689  
30690 C...Differential cross section expressions.
30691  
30692       IF(ISUB.LE.20) THEN
30693         IF(ISUB.EQ.10) THEN
30694 C...f + f' -> f + f' (gamma/Z/W exchange)
30695           FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30696           FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30697           FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30698           FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30699           DO 110 I=MMIN1,MMAX1
30700             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30701             IA=IABS(I)
30702             DO 100 J=MMIN2,MMAX2
30703               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30704               JA=IABS(J)
30705 C...Electroweak couplings
30706               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30707               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30708               VI=AI-4D0*EI*XWV
30709               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30710               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30711               VJ=AJ-4D0*EJ*XWV
30712               EPSIJ=ISIGN(1,I*J)
30713 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30714               IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30715                 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30716                   FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30717      &            (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30718      &            FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30719      &            4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30720                 ELSEIF(MSTP(21).EQ.2) THEN
30721                   FACNCF=FACGGF*EI**2*EJ**2
30722                 ELSE
30723                   FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30724      &            (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30725                 ENDIF
30726 C...Extrafactor 2 for only one incoming neutrino spin state.
30727                 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30728                 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30729                 NCHN=NCHN+1
30730                 ISIG(NCHN,1)=I
30731                 ISIG(NCHN,2)=J
30732                 ISIG(NCHN,3)=1
30733                 SIGH(NCHN)=FACNCF
30734               ENDIF
30735 C...W exchange
30736               IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30737                 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30738                 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30739                 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30740                 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30741                 NCHN=NCHN+1
30742                 ISIG(NCHN,1)=I
30743                 ISIG(NCHN,2)=J
30744                 ISIG(NCHN,3)=2
30745                 SIGH(NCHN)=FACCCF
30746               ENDIF
30747   100       CONTINUE
30748   110     CONTINUE
30749  
30750         ELSEIF(ISUB.EQ.11) THEN
30751 C...f + f' -> f + f' (g exchange)
30752           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30753           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30754      &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
30755           FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30756      &    MSTP(34)*2D0/3D0*SH2/(TH*UH))
30757           DO 130 I=MMIN1,MMAX1
30758             IA=IABS(I)
30759             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30760             DO 120 J=MMIN2,MMAX2
30761               JA=IABS(J)
30762               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30763               NCHN=NCHN+1
30764               ISIG(NCHN,1)=I
30765               ISIG(NCHN,2)=J
30766               ISIG(NCHN,3)=1
30767               SIGH(NCHN)=FACQQ1
30768               IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30769               IF(I.EQ.J) THEN
30770                 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30771                 NCHN=NCHN+1
30772                 ISIG(NCHN,1)=I
30773                 ISIG(NCHN,2)=J
30774                 ISIG(NCHN,3)=2
30775                 SIGH(NCHN)=0.5D0*FACQQ2
30776               ENDIF
30777   120       CONTINUE
30778   130     CONTINUE
30779  
30780         ELSEIF(ISUB.EQ.12) THEN
30781 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30782           CALL PYWIDT(21,SH,WDTP,WDTE)
30783           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30784      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30785           DO 140 I=MMINA,MMAXA
30786             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30787      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30788             NCHN=NCHN+1
30789             ISIG(NCHN,1)=I
30790             ISIG(NCHN,2)=-I
30791             ISIG(NCHN,3)=1
30792             SIGH(NCHN)=FACQQB
30793   140     CONTINUE
30794  
30795         ELSEIF(ISUB.EQ.13) THEN
30796 C...f + fbar -> g + g (q + qbar -> g + g only)
30797           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30798      &    UH2/SH2)
30799           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30800      &    TH2/SH2)
30801           DO 150 I=MMINA,MMAXA
30802             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30803      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30804             NCHN=NCHN+1
30805             ISIG(NCHN,1)=I
30806             ISIG(NCHN,2)=-I
30807             ISIG(NCHN,3)=1
30808             SIGH(NCHN)=0.5D0*FACGG1
30809             NCHN=NCHN+1
30810             ISIG(NCHN,1)=I
30811             ISIG(NCHN,2)=-I
30812             ISIG(NCHN,3)=2
30813             SIGH(NCHN)=0.5D0*FACGG2
30814   150     CONTINUE
30815  
30816         ELSEIF(ISUB.EQ.14) THEN
30817 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30818           FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30819           DO 160 I=MMINA,MMAXA
30820             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30821      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30822             EI=KCHG(IABS(I),1)/3D0
30823             NCHN=NCHN+1
30824             ISIG(NCHN,1)=I
30825             ISIG(NCHN,2)=-I
30826             ISIG(NCHN,3)=1
30827             SIGH(NCHN)=FACGG*EI**2
30828   160     CONTINUE
30829  
30830         ELSEIF(ISUB.EQ.18) THEN
30831 C...f + fbar -> gamma + gamma
30832           FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30833           DO 170 I=MMINA,MMAXA
30834             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30835             EI=KCHG(IABS(I),1)/3D0
30836             FCOI=1D0
30837             IF(IABS(I).LE.10) FCOI=FACA/3D0
30838             NCHN=NCHN+1
30839             ISIG(NCHN,1)=I
30840             ISIG(NCHN,2)=-I
30841             ISIG(NCHN,3)=1
30842             SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30843   170     CONTINUE
30844         ENDIF
30845  
30846       ELSEIF(ISUB.LE.40) THEN
30847         IF(ISUB.EQ.28) THEN
30848 C...f + g -> f + g (q + g -> q + g only)
30849           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30850      &    UH/SH)*FACA
30851           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30852      &    SH/UH)
30853           DO 190 I=MMINA,MMAXA
30854             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30855             DO 180 ISDE=1,2
30856               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30857               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30858               NCHN=NCHN+1
30859               ISIG(NCHN,ISDE)=I
30860               ISIG(NCHN,3-ISDE)=21
30861               ISIG(NCHN,3)=1
30862               SIGH(NCHN)=FACQG1
30863               NCHN=NCHN+1
30864               ISIG(NCHN,ISDE)=I
30865               ISIG(NCHN,3-ISDE)=21
30866               ISIG(NCHN,3)=2
30867               SIGH(NCHN)=FACQG2
30868   180       CONTINUE
30869   190     CONTINUE
30870  
30871         ELSEIF(ISUB.EQ.29) THEN
30872 C...f + g -> f + gamma (q + g -> q + gamma only)
30873           FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30874           DO 210 I=MMINA,MMAXA
30875             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30876             EI=KCHG(IABS(I),1)/3D0
30877             FACGQ=FGQ*EI**2
30878             DO 200 ISDE=1,2
30879               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30880               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30881               NCHN=NCHN+1
30882               ISIG(NCHN,ISDE)=I
30883               ISIG(NCHN,3-ISDE)=21
30884               ISIG(NCHN,3)=1
30885               SIGH(NCHN)=FACGQ
30886   200       CONTINUE
30887   210     CONTINUE
30888  
30889         ELSEIF(ISUB.EQ.33) THEN
30890 C...f + gamma -> f + g (q + gamma -> q + g only)
30891           FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30892           DO 230 I=MMINA,MMAXA
30893             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30894             EI=KCHG(IABS(I),1)/3D0
30895             FACGQ=FGQ*EI**2
30896             DO 220 ISDE=1,2
30897               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30898               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30899               NCHN=NCHN+1
30900               ISIG(NCHN,ISDE)=I
30901               ISIG(NCHN,3-ISDE)=22
30902               ISIG(NCHN,3)=1
30903               SIGH(NCHN)=FACGQ
30904   220       CONTINUE
30905   230     CONTINUE
30906  
30907         ELSEIF(ISUB.EQ.34) THEN
30908 C...f + gamma -> f + gamma
30909           FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30910           DO 250 I=MMINA,MMAXA
30911             IF(I.EQ.0) GOTO 250
30912             EI=KCHG(IABS(I),1)/3D0
30913             FACGQ=FGQ*EI**4
30914             DO 240 ISDE=1,2
30915               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30916               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30917               NCHN=NCHN+1
30918               ISIG(NCHN,ISDE)=I
30919               ISIG(NCHN,3-ISDE)=22
30920               ISIG(NCHN,3)=1
30921               SIGH(NCHN)=FACGQ
30922   240       CONTINUE
30923   250     CONTINUE
30924         ENDIF
30925  
30926       ELSEIF(ISUB.LE.80) THEN
30927         IF(ISUB.EQ.53) THEN
30928 C...g + g -> f + fbar (g + g -> q + qbar only)
30929           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30930           IDC0=MDCY(21,2)-1
30931 C...Begin by d, u, s flavours.
30932           FLAVWT=0D0
30933           IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30934      &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30935           IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30936      &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30937           IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30938      &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30939           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30940      &    UH2/SH2)*FLAVWT*FACA
30941           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30942      &    TH2/SH2)*FLAVWT*FACA
30943           NCHN=NCHN+1
30944           ISIG(NCHN,1)=21
30945           ISIG(NCHN,2)=21
30946           ISIG(NCHN,3)=1
30947           SIGH(NCHN)=FACQQ1
30948           NCHN=NCHN+1
30949           ISIG(NCHN,1)=21
30950           ISIG(NCHN,2)=21
30951           ISIG(NCHN,3)=2
30952           SIGH(NCHN)=FACQQ2
30953 C...Next c and b flavours: modified that and uhat for fixed
30954 C...cos(theta-hat).
30955           DO 260 IFL=4,5
30956           SQMAVG=PMAS(IFL,1)**2
30957           IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30958             BE34=SQRT(1D0-4D0*SQMAVG/SH)
30959             THQ=-0.5D0*SH*(1D0-BE34*CTH)
30960             UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30961             THUHQ=THQ*UHQ-SQMAVG*SH
30962             IF(MSTP(34).EQ.0) THEN
30963               FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30964               FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30965             ELSE
30966               FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30967      &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30968               FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30969      &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30970             ENDIF
30971             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30972             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30973             NCHN=NCHN+1
30974             ISIG(NCHN,1)=21
30975             ISIG(NCHN,2)=21
30976             ISIG(NCHN,3)=1+2*(IFL-3)
30977             SIGH(NCHN)=FACQQ1
30978             NCHN=NCHN+1
30979             ISIG(NCHN,1)=21
30980             ISIG(NCHN,2)=21
30981             ISIG(NCHN,3)=2+2*(IFL-3)
30982             SIGH(NCHN)=FACQQ2
30983           ENDIF
30984   260     CONTINUE
30985   270     CONTINUE
30986  
30987         ELSEIF(ISUB.EQ.54) THEN
30988 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30989           CALL PYWIDT(21,SH,WDTP,WDTE)
30990           WDTESU=0D0
30991           DO 280 I=1,MIN(8,MDCY(21,3))
30992             EF=KCHG(I,1)/3D0
30993             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30994      &      WDTE(I,4))
30995   280     CONTINUE
30996           FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30997           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30998             NCHN=NCHN+1
30999             ISIG(NCHN,1)=21
31000             ISIG(NCHN,2)=22
31001             ISIG(NCHN,3)=1
31002             SIGH(NCHN)=FACQQ
31003           ENDIF
31004           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31005             NCHN=NCHN+1
31006             ISIG(NCHN,1)=22
31007             ISIG(NCHN,2)=21
31008             ISIG(NCHN,3)=1
31009             SIGH(NCHN)=FACQQ
31010           ENDIF
31011  
31012         ELSEIF(ISUB.EQ.58) THEN
31013 C...gamma + gamma -> f + fbar
31014           CALL PYWIDT(22,SH,WDTP,WDTE)
31015           WDTESU=0D0
31016           DO 290 I=1,MIN(12,MDCY(22,3))
31017             IF(I.LE.8) EF= KCHG(I,1)/3D0
31018             IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31019             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31020      &      WDTE(I,4))
31021   290     CONTINUE
31022           FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
31023           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31024             NCHN=NCHN+1
31025             ISIG(NCHN,1)=22
31026             ISIG(NCHN,2)=22
31027             ISIG(NCHN,3)=1
31028             SIGH(NCHN)=FACFF
31029           ENDIF
31030  
31031         ELSEIF(ISUB.EQ.68) THEN
31032 C...g + g -> g + g
31033           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
31034           FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
31035      &    TH2/SH2)*FACA
31036           FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
31037      &    SH2/UH2)*FACA
31038           FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
31039      &    UH2/TH2)
31040           NCHN=NCHN+1
31041           ISIG(NCHN,1)=21
31042           ISIG(NCHN,2)=21
31043           ISIG(NCHN,3)=1
31044           SIGH(NCHN)=0.5D0*FACGG1
31045           NCHN=NCHN+1
31046           ISIG(NCHN,1)=21
31047           ISIG(NCHN,2)=21
31048           ISIG(NCHN,3)=2
31049           SIGH(NCHN)=0.5D0*FACGG2
31050           NCHN=NCHN+1
31051           ISIG(NCHN,1)=21
31052           ISIG(NCHN,2)=21
31053           ISIG(NCHN,3)=3
31054           SIGH(NCHN)=0.5D0*FACGG3
31055   300     CONTINUE
31056  
31057         ELSEIF(ISUB.EQ.80) THEN
31058 C...q + gamma -> q' + pi+/-
31059           FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
31060           ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
31061           Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
31062           DELSH=UH*SQRT(ASSH*Q2FPSH)
31063           ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
31064           Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
31065           DELUH=SH*SQRT(ASUH*Q2FPUH)
31066           DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
31067             IF(I.EQ.0) GOTO 320
31068             EI=KCHG(IABS(I),1)/3D0
31069             EJ=SIGN(1D0-ABS(EI),EI)
31070             DO 310 ISDE=1,2
31071               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
31072               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
31073               NCHN=NCHN+1
31074               ISIG(NCHN,ISDE)=I
31075               ISIG(NCHN,3-ISDE)=22
31076               ISIG(NCHN,3)=1
31077               SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
31078   310       CONTINUE
31079   320     CONTINUE
31080         ENDIF
31081  
31082       ELSEIF(ISUB.LE.100) THEN
31083         IF(ISUB.EQ.91) THEN
31084 C...Elastic scattering
31085           SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
31086  
31087         ELSEIF(ISUB.EQ.92) THEN
31088 C...Single diffractive scattering (first side, i.e. XB)
31089           SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
31090  
31091         ELSEIF(ISUB.EQ.93) THEN
31092 C...Single diffractive scattering (second side, i.e. AX)
31093           SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
31094  
31095         ELSEIF(ISUB.EQ.94) THEN
31096 C...Double diffractive scattering
31097           SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
31098  
31099         ELSEIF(ISUB.EQ.95) THEN
31100 C...Low-pT scattering
31101           SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
31102  
31103         ELSEIF(ISUB.EQ.96) THEN
31104 C...Multiple interactions: sum of QCD processes
31105           CALL PYWIDT(21,SH,WDTP,WDTE)
31106  
31107 C...q + q' -> q + q'
31108           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
31109           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
31110      &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
31111           FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
31112           FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
31113           RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
31114           DO 340 I=-5,5
31115             IF(I.EQ.0) GOTO 340
31116             DO 330 J=-5,5
31117               IF(J.EQ.0) GOTO 330
31118               NCHN=NCHN+1
31119               ISIG(NCHN,1)=I
31120               ISIG(NCHN,2)=J
31121               ISIG(NCHN,3)=111
31122               SIGH(NCHN)=FACQQ1
31123               IF(I.EQ.-J) SIGH(NCHN)=FACQQB
31124               IF(I.EQ.J) THEN
31125                 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
31126                 NCHN=NCHN+1
31127                 ISIG(NCHN,1)=I
31128                 ISIG(NCHN,2)=J
31129                 ISIG(NCHN,3)=112
31130                 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
31131               ENDIF
31132   330       CONTINUE
31133   340     CONTINUE
31134  
31135 C...q + qbar -> q' + qbar' or g + g
31136           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
31137      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
31138           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31139      &    UH2/SH2)
31140           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31141      &    TH2/SH2)
31142           DO 350 I=-5,5
31143             IF(I.EQ.0) GOTO 350
31144             NCHN=NCHN+1
31145             ISIG(NCHN,1)=I
31146             ISIG(NCHN,2)=-I
31147             ISIG(NCHN,3)=121
31148             SIGH(NCHN)=FACQQB
31149             NCHN=NCHN+1
31150             ISIG(NCHN,1)=I
31151             ISIG(NCHN,2)=-I
31152             ISIG(NCHN,3)=131
31153             SIGH(NCHN)=0.5D0*FACGG1
31154             NCHN=NCHN+1
31155             ISIG(NCHN,1)=I
31156             ISIG(NCHN,2)=-I
31157             ISIG(NCHN,3)=132
31158             SIGH(NCHN)=0.5D0*FACGG2
31159   350     CONTINUE
31160  
31161 C...q + g -> q + g
31162           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
31163      &    UH/SH)*FACA
31164           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
31165      &    SH/UH)
31166           DO 370 I=-5,5
31167             IF(I.EQ.0) GOTO 370
31168             DO 360 ISDE=1,2
31169               NCHN=NCHN+1
31170               ISIG(NCHN,ISDE)=I
31171               ISIG(NCHN,3-ISDE)=21
31172               ISIG(NCHN,3)=281
31173               SIGH(NCHN)=FACQG1
31174               NCHN=NCHN+1
31175               ISIG(NCHN,ISDE)=I
31176               ISIG(NCHN,3-ISDE)=21
31177               ISIG(NCHN,3)=282
31178               SIGH(NCHN)=FACQG2
31179   360       CONTINUE
31180   370     CONTINUE
31181  
31182 C...g + g -> q + qbar (only d, u, s)
31183           IDC0=MDCY(21,2)-1
31184           FLAVWT=0D0
31185           IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
31186      &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
31187           IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
31188      &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
31189           IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
31190      &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
31191           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31192      &    UH2/SH2)*FLAVWT*FACA
31193           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31194      &    TH2/SH2)*FLAVWT*FACA
31195           NCHN=NCHN+1
31196           ISIG(NCHN,1)=21
31197           ISIG(NCHN,2)=21
31198           ISIG(NCHN,3)=531
31199           SIGH(NCHN)=FACQQ1
31200           NCHN=NCHN+1
31201           ISIG(NCHN,1)=21
31202           ISIG(NCHN,2)=21
31203           ISIG(NCHN,3)=532
31204           SIGH(NCHN)=FACQQ2
31205  
31206 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
31207 C...cos(theta-hat)
31208           DO 380 IFL=4,5
31209           SQMAVG=PMAS(IFL,1)**2
31210           IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
31211             BE34=SQRT(1D0-4D0*SQMAVG/SH)
31212             THQ=-0.5D0*SH*(1D0-BE34*CTH)
31213             UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31214             THUHQ=THQ*UHQ-SQMAVG*SH
31215             IF(MSTP(34).EQ.0) THEN
31216               FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31217               FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31218             ELSE
31219               FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31220      &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31221               FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31222      &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31223             ENDIF
31224             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
31225             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
31226             NCHN=NCHN+1
31227             ISIG(NCHN,1)=21
31228             ISIG(NCHN,2)=21
31229             ISIG(NCHN,3)=531+2*(IFL-3)
31230             SIGH(NCHN)=FACQQ1
31231             NCHN=NCHN+1
31232             ISIG(NCHN,1)=21
31233             ISIG(NCHN,2)=21
31234             ISIG(NCHN,3)=532+2*(IFL-3)
31235             SIGH(NCHN)=FACQQ2
31236           ENDIF
31237   380     CONTINUE
31238  
31239 C...g + g -> g + g
31240           FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
31241      &    2D0*TH/SH+TH2/SH2)*FACA
31242           FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
31243      &    2D0*SH/UH+SH2/UH2)*FACA
31244           FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
31245      &    2D0*UH/TH+UH2/TH2)
31246           NCHN=NCHN+1
31247           ISIG(NCHN,1)=21
31248           ISIG(NCHN,2)=21
31249           ISIG(NCHN,3)=681
31250           SIGH(NCHN)=0.5D0*FACGG1
31251           NCHN=NCHN+1
31252           ISIG(NCHN,1)=21
31253           ISIG(NCHN,2)=21
31254           ISIG(NCHN,3)=682
31255           SIGH(NCHN)=0.5D0*FACGG2
31256           NCHN=NCHN+1
31257           ISIG(NCHN,1)=21
31258           ISIG(NCHN,2)=21
31259           ISIG(NCHN,3)=683
31260           SIGH(NCHN)=0.5D0*FACGG3
31261  
31262         ELSEIF(ISUB.EQ.99) THEN
31263 C...f + gamma* -> f.
31264           IF(MINT(107).EQ.4) THEN
31265             Q2GA=VINT(307)
31266             P2GA=VINT(308)
31267             ISDE=2
31268           ELSE
31269             Q2GA=VINT(308)
31270             P2GA=VINT(307)
31271             ISDE=1
31272           ENDIF
31273           COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
31274           PM2RHO=PMAS(PYCOMP(113),1)**2
31275           IF(MSTP(19).EQ.0) THEN
31276             COMFAC=COMFAC/Q2GA
31277           ELSEIF(MSTP(19).EQ.1) THEN
31278             COMFAC=COMFAC/(Q2GA+PM2RHO)
31279           ELSEIF(MSTP(19).EQ.2) THEN
31280             COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31281           ELSE
31282             COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31283             W2GA=VINT(2)
31284             IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
31285               RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
31286      &        Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
31287               XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
31288             ELSE
31289               RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
31290      &        Q2GA**0.57D0)
31291               XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
31292             ENDIF
31293             COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
31294             IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
31295           ENDIF
31296           DO 390 I=MMINA,MMAXA
31297             IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
31298             IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
31299             EI=KCHG(IABS(I),1)/3D0
31300             NCHN=NCHN+1
31301             ISIG(NCHN,ISDE)=I
31302             ISIG(NCHN,3-ISDE)=22
31303             ISIG(NCHN,3)=1
31304             SIGH(NCHN)=COMFAC*EI**2
31305   390     CONTINUE
31306         ENDIF
31307  
31308       ELSE
31309         IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
31310 C...g + g -> gamma + gamma or g + g -> g + gamma
31311           A0STUR=0D0
31312           A0STUI=0D0
31313           A0TSUR=0D0
31314           A0TSUI=0D0
31315           A0UTSR=0D0
31316           A0UTSI=0D0
31317           A1STUR=0D0
31318           A1STUI=0D0
31319           A2STUR=0D0
31320           A2STUI=0D0
31321           ALST=LOG(-SH/TH)
31322           ALSU=LOG(-SH/UH)
31323           ALTU=LOG(TH/UH)
31324           IMAX=2*MSTP(1)
31325           IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
31326           DO 400 I=1,IMAX
31327             EI=KCHG(IABS(I),1)/3D0
31328             EIWT=EI**2
31329             IF(ISUB.EQ.115) EIWT=EI
31330             SQMQ=PMAS(I,1)**2
31331             EPSS=4D0*SQMQ/SH
31332             EPST=4D0*SQMQ/TH
31333             EPSU=4D0*SQMQ/UH
31334             IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
31335               B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
31336      &        PARU(1)**2)
31337               B0STUI=0D0
31338               B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
31339               B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
31340               B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
31341               B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
31342               B1STUR=-1D0
31343               B1STUI=0D0
31344               B2STUR=-1D0
31345               B2STUI=0D0
31346             ELSE
31347               CALL PYWAUX(1,EPSS,W1SR,W1SI)
31348               CALL PYWAUX(1,EPST,W1TR,W1TI)
31349               CALL PYWAUX(1,EPSU,W1UR,W1UI)
31350               CALL PYWAUX(2,EPSS,W2SR,W2SI)
31351               CALL PYWAUX(2,EPST,W2TR,W2TI)
31352               CALL PYWAUX(2,EPSU,W2UR,W2UI)
31353               CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
31354               CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
31355               CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
31356               CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
31357               CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
31358               CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
31359               B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
31360      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
31361      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
31362      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
31363      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31364      &        0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31365               B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
31366      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
31367      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
31368      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
31369      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31370      &        0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31371               B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
31372      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
31373      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
31374      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
31375      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31376      &        0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
31377               B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
31378      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
31379      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
31380      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
31381      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31382      &        0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
31383               B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
31384      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
31385      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
31386      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
31387      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31388      &        0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
31389               B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
31390      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
31391      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
31392      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
31393      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31394      &        0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
31395               B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
31396      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
31397      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
31398      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31399               B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
31400      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
31401      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
31402      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31403               B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
31404      &        0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
31405      &        0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
31406               B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
31407      &        0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
31408      &        0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
31409             ENDIF
31410             A0STUR=A0STUR+EIWT*B0STUR
31411             A0STUI=A0STUI+EIWT*B0STUI
31412             A0TSUR=A0TSUR+EIWT*B0TSUR
31413             A0TSUI=A0TSUI+EIWT*B0TSUI
31414             A0UTSR=A0UTSR+EIWT*B0UTSR
31415             A0UTSI=A0UTSI+EIWT*B0UTSI
31416             A1STUR=A1STUR+EIWT*B1STUR
31417             A1STUI=A1STUI+EIWT*B1STUI
31418             A2STUR=A2STUR+EIWT*B2STUR
31419             A2STUI=A2STUI+EIWT*B2STUI
31420   400     CONTINUE
31421           ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
31422      &    A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
31423           FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
31424           FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
31425           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
31426           NCHN=NCHN+1
31427           ISIG(NCHN,1)=21
31428           ISIG(NCHN,2)=21
31429           ISIG(NCHN,3)=1
31430           IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
31431           IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
31432   410     CONTINUE
31433  
31434         ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
31435 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
31436           PH=0D0
31437           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31438      &    PH=VINT(3)**2
31439           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31440      &    PH=VINT(4)**2
31441           IF(ISUB.EQ.131) THEN
31442             FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
31443      &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31444           ELSE
31445             FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31446           ENDIF
31447           DO 430 I=MMINA,MMAXA
31448             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
31449             EI=KCHG(IABS(I),1)/3D0
31450             FACGQ=FGQ*EI**2
31451             DO 420 ISDE=1,2
31452               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
31453               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
31454               NCHN=NCHN+1
31455               ISIG(NCHN,ISDE)=I
31456               ISIG(NCHN,3-ISDE)=22
31457               ISIG(NCHN,3)=1
31458               SIGH(NCHN)=FACGQ
31459   420       CONTINUE
31460   430     CONTINUE
31461  
31462         ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
31463 C...f + gamma*_(T,L) -> f + gamma
31464           PH=0D0
31465           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31466      &    PH=VINT(3)**2
31467           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31468      &    PH=VINT(4)**2
31469           IF(ISUB.EQ.133) THEN
31470             FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
31471      &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31472           ELSE
31473             FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31474           ENDIF
31475           DO 450 I=MMINA,MMAXA
31476             IF(I.EQ.0) GOTO 450
31477             EI=KCHG(IABS(I),1)/3D0
31478             FACGQ=FGQ*EI**4
31479             DO 440 ISDE=1,2
31480               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
31481               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
31482               NCHN=NCHN+1
31483               ISIG(NCHN,ISDE)=I
31484               ISIG(NCHN,3-ISDE)=22
31485               ISIG(NCHN,3)=1
31486               SIGH(NCHN)=FACGQ
31487   440       CONTINUE
31488   450     CONTINUE
31489  
31490         ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
31491 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
31492           PH=0D0
31493           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31494      &    PH=VINT(3)**2
31495           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31496      &    PH=VINT(4)**2
31497           CALL PYWIDT(21,SH,WDTP,WDTE)
31498           WDTESU=0D0
31499           DO 460 I=1,MIN(8,MDCY(21,3))
31500             EF=KCHG(I,1)/3D0
31501             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31502      &      WDTE(I,4))
31503   460     CONTINUE
31504           IF(ISUB.EQ.135) THEN
31505             FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
31506      &      ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
31507           ELSE
31508             FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
31509           ENDIF
31510           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31511             NCHN=NCHN+1
31512             ISIG(NCHN,1)=21
31513             ISIG(NCHN,2)=22
31514             ISIG(NCHN,3)=1
31515             SIGH(NCHN)=FACQQ
31516           ENDIF
31517           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31518             NCHN=NCHN+1
31519             ISIG(NCHN,1)=22
31520             ISIG(NCHN,2)=21
31521             ISIG(NCHN,3)=1
31522             SIGH(NCHN)=FACQQ
31523           ENDIF
31524  
31525         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
31526 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
31527           PH1=0D0
31528           IF(VINT(3).LT.0D0) PH1=VINT(3)**2
31529           PH2=0D0
31530           IF(VINT(4).LT.0D0) PH2=VINT(4)**2
31531           CALL PYWIDT(22,SH,WDTP,WDTE)
31532           WDTESU=0D0
31533           DO 470 I=1,MIN(12,MDCY(22,3))
31534             IF(I.LE.8) EF= KCHG(I,1)/3D0
31535             IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31536             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31537      &      WDTE(I,4))
31538   470     CONTINUE
31539           DLAMB2=(TH+UH)**2-4D0*PH1*PH2
31540           IF(ISUB.EQ.137) THEN
31541             FPARAM=-SH*(TH+UH)/DLAMB2
31542             FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
31543      &      (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
31544      &      2D0*PH1*PH2*FPARAM**2)
31545           ELSEIF(ISUB.EQ.138) THEN
31546             FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31547      &      PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
31548      &      2D0*PH1**2*(TH-UH)**2)
31549           ELSEIF(ISUB.EQ.139) THEN
31550             FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31551      &      PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
31552      &      2D0*PH2**2*(TH-UH)**2)
31553           ELSE
31554             FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
31555      &      PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
31556           ENDIF
31557           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31558             NCHN=NCHN+1
31559             ISIG(NCHN,1)=22
31560             ISIG(NCHN,2)=22
31561             ISIG(NCHN,3)=1
31562             SIGH(NCHN)=FACFF
31563           ENDIF
31564  
31565         ENDIF
31566       ENDIF
31567  
31568       RETURN
31569       END
31570  
31571 C*********************************************************************
31572  
31573 C...PYSGHF
31574 C...Subprocess cross sections for heavy flavour production,
31575 C...open and closed.
31576 C...Auxiliary to PYSIGH.
31577  
31578       SUBROUTINE PYSGHF(NCHN,SIGS)
31579  
31580 C...Double precision and integer declarations
31581       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31582       IMPLICIT INTEGER(I-N)
31583       INTEGER PYK,PYCHGE,PYCOMP
31584 C...Parameter statement to help give large particle numbers.
31585       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31586      &KEXCIT=4000000,KDIMEN=5000000)
31587 C...Commonblocks
31588       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31589       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31590       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31591       COMMON/PYINT1/MINT(400),VINT(400)
31592       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31593       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31594       COMMON/PYINT4/MWID(500),WIDS(500,5)
31595       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31596      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31597      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31598      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31599       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
31600      &/PYINT4/,/PYSGCM/
31601 C...Local arrays
31602       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31603  
31604 C...Determine where are charmonium/bottomonium wave function parameters.
31605       IONIUM=140
31606       IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
31607  
31608 C...Convert bottomonium process into equivalent charmonium ones.
31609       IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
31610  
31611 C...Differential cross section expressions.
31612  
31613       IF(ISUB.LE.100) THEN
31614         IF(ISUB.EQ.81) THEN
31615 C...q + qbar -> Q + Qbar
31616           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31617           THQ=-0.5D0*SH*(1D0-BE34*CTH)
31618           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31619           FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
31620      &    2D0*SQMAVG/SH)
31621           IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
31622           WID2=1D0
31623           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31624           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31625           FACQQB=FACQQB*WID2
31626           DO 100 I=MMINA,MMAXA
31627             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31628      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31629             NCHN=NCHN+1
31630             ISIG(NCHN,1)=I
31631             ISIG(NCHN,2)=-I
31632             ISIG(NCHN,3)=1
31633             SIGH(NCHN)=FACQQB
31634   100     CONTINUE
31635  
31636         ELSEIF(ISUB.EQ.82) THEN
31637 C...g + g -> Q + Qbar
31638           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31639           THQ=-0.5D0*SH*(1D0-BE34*CTH)
31640           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31641           THUHQ=THQ*UHQ-SQMAVG*SH
31642           IF(MSTP(34).EQ.0) THEN
31643             FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31644             FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31645           ELSE
31646             FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31647      &      THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31648             FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31649      &      UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31650           ENDIF
31651           FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
31652           FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
31653           IF(MSTP(35).GE.1) THEN
31654             FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
31655             FACQQ1=FACQQ1*FATRE
31656             FACQQ2=FACQQ2*FATRE
31657           ENDIF
31658           WID2=1D0
31659           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31660           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31661           FACQQ1=FACQQ1*WID2
31662           FACQQ2=FACQQ2*WID2
31663           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31664           NCHN=NCHN+1
31665           ISIG(NCHN,1)=21
31666           ISIG(NCHN,2)=21
31667           ISIG(NCHN,3)=1
31668           SIGH(NCHN)=FACQQ1
31669           NCHN=NCHN+1
31670           ISIG(NCHN,1)=21
31671           ISIG(NCHN,2)=21
31672           ISIG(NCHN,3)=2
31673           SIGH(NCHN)=FACQQ2
31674   110     CONTINUE
31675  
31676         ELSEIF(ISUB.EQ.83) THEN
31677 C...f + q -> f' + Q
31678           FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31679           FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31680           DO 130 I=MMIN1,MMAX1
31681             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31682             DO 120 J=MMIN2,MMAX2
31683               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31684               IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31685               IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31686               IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31687      &        THEN
31688                 NCHN=NCHN+1
31689                 ISIG(NCHN,1)=I
31690                 ISIG(NCHN,2)=J
31691                 ISIG(NCHN,3)=1
31692                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31693      &          (IABS(I)+1)/2)*VINT(180+J)
31694                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31695      &          (MINT(55)+1)/2)*VINT(180+J)
31696                 WID2=1D0
31697                 IF(I.GT.0) THEN
31698                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31699                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31700      &            WIDS(MINT(55),2)
31701                 ELSE
31702                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31703                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31704      &            WIDS(MINT(55),3)
31705                 ENDIF
31706                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31707                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31708               ENDIF
31709               IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31710      &        THEN
31711                 NCHN=NCHN+1
31712                 ISIG(NCHN,1)=I
31713                 ISIG(NCHN,2)=J
31714                 ISIG(NCHN,3)=2
31715                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31716      &          (IABS(J)+1)/2)*VINT(180+I)
31717                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31718      &          (MINT(55)+1)/2)*VINT(180+I)
31719                 WID2=1D0
31720                 IF(J.GT.0) THEN
31721                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31722                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31723      &            WIDS(MINT(55),2)
31724                 ELSE
31725                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31726                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31727      &            WIDS(MINT(55),3)
31728                 ENDIF
31729                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31730                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31731               ENDIF
31732   120       CONTINUE
31733   130     CONTINUE
31734  
31735         ELSEIF(ISUB.EQ.84) THEN
31736 C...g + gamma -> Q + Qbar
31737           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31738           THQ=-0.5D0*SH*(1D0-BE34*CTH)
31739           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31740           FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31741      &    (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31742      &    (THQ*UHQ)
31743           IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31744           WID2=1D0
31745           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31746           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31747           FACQQ=FACQQ*WID2
31748           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31749             NCHN=NCHN+1
31750             ISIG(NCHN,1)=21
31751             ISIG(NCHN,2)=22
31752             ISIG(NCHN,3)=1
31753             SIGH(NCHN)=FACQQ
31754           ENDIF
31755           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31756             NCHN=NCHN+1
31757             ISIG(NCHN,1)=22
31758             ISIG(NCHN,2)=21
31759             ISIG(NCHN,3)=1
31760             SIGH(NCHN)=FACQQ
31761           ENDIF
31762  
31763         ELSEIF(ISUB.EQ.85) THEN
31764 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31765           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31766           THQ=-0.5D0*SH*(1D0-BE34*CTH)
31767           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31768           FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31769      &    ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31770      &    (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31771      &    SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31772           IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31773           IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31774      &    FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31775           WID2=1D0
31776           IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31777           IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31778           IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31779           FACFF=FACFF*WID2
31780           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31781             NCHN=NCHN+1
31782             ISIG(NCHN,1)=22
31783             ISIG(NCHN,2)=22
31784             ISIG(NCHN,3)=1
31785             SIGH(NCHN)=FACFF
31786           ENDIF
31787  
31788         ELSEIF(ISUB.EQ.86) THEN
31789 C...g + g -> J/Psi + g
31790           FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31791      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31792      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31793           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31794             NCHN=NCHN+1
31795             ISIG(NCHN,1)=21
31796             ISIG(NCHN,2)=21
31797             ISIG(NCHN,3)=1
31798             SIGH(NCHN)=FACQQG
31799           ENDIF
31800  
31801         ELSEIF(ISUB.EQ.87) THEN
31802 C...g + g -> chi_0c + g
31803           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31804           QGTW=(SH*TH*UH)/SH**3
31805           RGTW=SQM3/SH
31806           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31807      &    (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31808      &    6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31809      &    PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31810      &    2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31811      &    (QGTW*(QGTW-RGTW*PGTW)**4)
31812           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31813             NCHN=NCHN+1
31814             ISIG(NCHN,1)=21
31815             ISIG(NCHN,2)=21
31816             ISIG(NCHN,3)=1
31817             SIGH(NCHN)=FACQQG
31818           ENDIF
31819  
31820         ELSEIF(ISUB.EQ.88) THEN
31821 C...g + g -> chi_1c + g
31822           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31823           QGTW=(SH*TH*UH)/SH**3
31824           RGTW=SQM3/SH
31825           FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31826      &    PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31827      &    5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31828      &    (QGTW-RGTW*PGTW)**4
31829           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31830             NCHN=NCHN+1
31831             ISIG(NCHN,1)=21
31832             ISIG(NCHN,2)=21
31833             ISIG(NCHN,3)=1
31834             SIGH(NCHN)=FACQQG
31835           ENDIF
31836  
31837         ELSEIF(ISUB.EQ.89) THEN
31838 C...g + g -> chi_2c + g
31839           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31840           QGTW=(SH*TH*UH)/SH**3
31841           RGTW=SQM3/SH
31842           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31843      &    (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31844      &    3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31845      &    2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31846      &    RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31847      &    QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31848           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31849             NCHN=NCHN+1
31850             ISIG(NCHN,1)=21
31851             ISIG(NCHN,2)=21
31852             ISIG(NCHN,3)=1
31853             SIGH(NCHN)=FACQQG
31854           ENDIF
31855         ENDIF
31856  
31857       ELSEIF(ISUB.LE.200) THEN
31858         IF(ISUB.EQ.104) THEN
31859 C...g + g -> chi_c0.
31860           KC=PYCOMP(10441)
31861           FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31862      &    ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31863           IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31864           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31865             NCHN=NCHN+1
31866             ISIG(NCHN,1)=21
31867             ISIG(NCHN,2)=21
31868             ISIG(NCHN,3)=1
31869             SIGH(NCHN)=FACBW
31870           ENDIF
31871  
31872         ELSEIF(ISUB.EQ.105) THEN
31873 C...g + g -> chi_c2.
31874           KC=PYCOMP(445)
31875           FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31876      &    ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31877           IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31878           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31879             NCHN=NCHN+1
31880             ISIG(NCHN,1)=21
31881             ISIG(NCHN,2)=21
31882             ISIG(NCHN,3)=1
31883             SIGH(NCHN)=FACBW
31884           ENDIF
31885  
31886         ELSEIF(ISUB.EQ.106) THEN
31887 C...g + g -> J/Psi + gamma.
31888           EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31889           FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31890      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31891      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31892           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31893             NCHN=NCHN+1
31894             ISIG(NCHN,1)=21
31895             ISIG(NCHN,2)=21
31896             ISIG(NCHN,3)=1
31897             SIGH(NCHN)=FACQQG
31898           ENDIF
31899  
31900         ELSEIF(ISUB.EQ.107) THEN
31901 C...g + gamma -> J/Psi + g.
31902           EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31903           FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31904      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31905      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31906           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31907             NCHN=NCHN+1
31908             ISIG(NCHN,1)=21
31909             ISIG(NCHN,2)=22
31910             ISIG(NCHN,3)=1
31911             SIGH(NCHN)=FACQQG
31912           ENDIF
31913           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31914             NCHN=NCHN+1
31915             ISIG(NCHN,1)=22
31916             ISIG(NCHN,2)=21
31917             ISIG(NCHN,3)=1
31918             SIGH(NCHN)=FACQQG
31919           ENDIF
31920  
31921         ELSEIF(ISUB.EQ.108) THEN
31922 C...gamma + gamma -> J/Psi + gamma.
31923           EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31924           FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31925      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31926      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31927           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31928             NCHN=NCHN+1
31929             ISIG(NCHN,1)=22
31930             ISIG(NCHN,2)=22
31931             ISIG(NCHN,3)=1
31932             SIGH(NCHN)=FACQQG
31933           ENDIF
31934         ENDIF
31935  
31936 C...QUARKONIA+++
31937 C...Additional code by Stefan Wolf
31938       ELSE
31939  
31940 C...Common code for quarkonium production.
31941         SHTH=SH+TH
31942         THUH=TH+UH
31943         UHSH=UH+SH
31944         SHTH2=SHTH**2
31945         THUH2=THUH**2
31946         UHSH2=UHSH**2
31947         IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31948      &       (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31949           SQMQQ=SQM3
31950         ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31951      &         (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31952           SQMQQ=SQM4
31953         ENDIF
31954         SQMQQR=SQRT(SQMQQ)
31955         IF(MSTP(145).EQ.1) THEN
31956            IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31957      &          (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31958               AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31959               BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31960               ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31961               ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31962               BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31963               BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31964            ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31965      &             ISUB.GE.437) THEN
31966               AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31967               BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31968               ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31969               ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31970               BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31971               BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31972            ENDIF
31973            AQ2=AQ**2
31974            BQ2=BQ**2
31975            SMQQ2=SQMQQ*VINT(2)
31976 C...Polarisation frames
31977            IF(MSTP(146).EQ.1) THEN
31978 C...Recoil frame
31979               POLH1=SQRT(AQ2-SMQQ2)
31980               POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31981               AZ=-SQMQQR/POLH1
31982               BZ=0D0
31983               AX=AQ*BQ/(POLH1*POLH2)
31984               BX=-POLH1/POLH2
31985            ELSEIF(MSTP(146).EQ.2) THEN
31986 C...Gottfried Jackson frame
31987               POLH1=AQ+BQ
31988               POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31989               AZ=SQMQQR/POLH1
31990               BZ=AZ
31991               AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31992               BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31993            ELSEIF(MSTP(146).EQ.3) THEN
31994 C...Target frame
31995               POLH1=AQ-BQ
31996               POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31997               AZ=-SQMQQR/POLH1
31998               BZ=-AZ
31999               AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
32000               BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
32001            ELSEIF(MSTP(146).EQ.4) THEN
32002 C...Collins Soper frame
32003               POLH1=AQ2-BQ2
32004               POLH2=SQRT(VINT(2)*POLH1)
32005               AZ=-BQ/POLH2
32006               BZ=AQ/POLH2
32007               AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
32008               BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
32009            ENDIF
32010 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
32011            EL1K10=AZ*ATILK1+BZ*BTILK1
32012            EL1K20=AZ*ATILK2+BZ*BTILK2
32013            EL2K10=EL1K10
32014            EL2K20=EL1K20
32015            EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
32016            EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
32017            EL2K11=EL1K11
32018            EL2K21=EL1K21
32019         ENDIF
32020  
32021         IF(ISUB.EQ.421) THEN
32022 C...g + g -> QQ~[3S11] + g
32023           IF(MSTP(145).EQ.0) THEN
32024 *            FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32025 *     &            (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
32026             FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32027      &            (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
32028 *            FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32029 *     &           (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
32030           ELSE
32031             FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
32032             AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32033             BB=2D0*(SH2+TH2)
32034             CC=2D0*(SH2+UH2)
32035             DD=2D0*SH2
32036             IF(MSTP(147).EQ.0) THEN
32037                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32038      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32039             ELSEIF(MSTP(147).EQ.1) THEN
32040                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32041      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32042             ELSEIF(MSTP(147).EQ.3) THEN
32043                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32044      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32045             ELSEIF(MSTP(147).EQ.4) THEN
32046                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32047      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32048             ELSEIF(MSTP(147).EQ.5) THEN
32049                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32050      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32051             ELSEIF(MSTP(147).EQ.6) THEN
32052                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32053      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32054             ENDIF
32055             FACQQG=COMFAC*FF*FACQQG
32056           ENDIF
32057           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32058             NCHN=NCHN+1
32059             ISIG(NCHN,1)=21
32060             ISIG(NCHN,2)=21
32061             ISIG(NCHN,3)=1
32062             SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
32063           ENDIF
32064  
32065         ELSEIF(ISUB.EQ.422) THEN
32066 C...g + g -> QQ~[3S18] + g
32067           IF(MSTP(145).EQ.0) THEN
32068             FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
32069      &            (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32070      &            (SQMQQ*SQMQQR)*
32071      &            ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
32072           ELSE
32073             FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32074      &            (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
32075             AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32076             BB=2D0*(SH2+TH2)
32077             CC=2D0*(SH2+UH2)
32078             DD=2D0*SH2
32079             IF(MSTP(147).EQ.0) THEN
32080                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32081      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32082             ELSEIF(MSTP(147).EQ.1) THEN
32083                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32084      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32085             ELSEIF(MSTP(147).EQ.3) THEN
32086                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32087      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32088             ELSEIF(MSTP(147).EQ.4) THEN
32089                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32090      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32091             ELSEIF(MSTP(147).EQ.5) THEN
32092                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32093      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32094             ELSEIF(MSTP(147).EQ.6) THEN
32095                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32096      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32097             ENDIF
32098             FACQQG=COMFAC*FF*FACQQG
32099           ENDIF
32100 C...Split total contribution into different colour flows just like
32101 C...in g g -> g g (recalculate kinematics for massless partons).
32102           THP=-0.5D0*SH*(1D0-CTH)
32103           UHP=-0.5D0*SH*(1D0+CTH)
32104           FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32105           FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32106           FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32107           FACGGS=FACGG1+FACGG2+FACGG3
32108           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32109              NCHN=NCHN+1
32110              ISIG(NCHN,1)=21
32111              ISIG(NCHN,2)=21
32112              ISIG(NCHN,3)=1
32113              SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32114              NCHN=NCHN+1
32115              ISIG(NCHN,1)=21
32116              ISIG(NCHN,2)=21
32117              ISIG(NCHN,3)=2
32118              SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32119              NCHN=NCHN+1
32120              ISIG(NCHN,1)=21
32121              ISIG(NCHN,2)=21
32122              ISIG(NCHN,3)=3
32123              SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
32124           ENDIF
32125  
32126         ELSEIF(ISUB.EQ.423) THEN
32127 C...g + g -> QQ~[1S08] + g
32128           IF(MSTP(145).EQ.0) THEN
32129 *            FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
32130 *     &           (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
32131 *     &           (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
32132 *     &           (SHTH2*THUH2*UHSH2)
32133             FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
32134      &            (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32135      &            TH2/(SHTH2*THUH2))*
32136      &            (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32137           ELSE
32138             FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
32139      &            (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32140      &            TH2/(SHTH2*THUH2))*
32141      &            (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32142             IF(MSTP(147).EQ.0) THEN
32143                FACQQG=COMFAC*FA
32144             ELSEIF(MSTP(147).EQ.1) THEN
32145                FACQQG=COMFAC*2D0*FA
32146             ELSEIF(MSTP(147).EQ.3) THEN
32147                FACQQG=COMFAC*FA
32148             ELSEIF(MSTP(147).EQ.4) THEN
32149                FACQQG=COMFAC*FA
32150             ELSEIF(MSTP(147).EQ.5) THEN
32151                FACQQG=0D0
32152             ELSEIF(MSTP(147).EQ.6) THEN
32153                FACQQG=0D0
32154             ENDIF
32155           ENDIF
32156 C...Split total contribution into different colour flows just like
32157 C...in g g -> g g (recalculate kinematics for massless partons).
32158           THP=-0.5D0*SH*(1D0-CTH)
32159           UHP=-0.5D0*SH*(1D0+CTH)
32160           FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32161           FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32162           FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32163           FACGGS=FACGG1+FACGG2+FACGG3
32164           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32165              NCHN=NCHN+1
32166              ISIG(NCHN,1)=21
32167              ISIG(NCHN,2)=21
32168              ISIG(NCHN,3)=1
32169              SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32170              NCHN=NCHN+1
32171              ISIG(NCHN,1)=21
32172              ISIG(NCHN,2)=21
32173              ISIG(NCHN,3)=2
32174              SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32175              NCHN=NCHN+1
32176              ISIG(NCHN,1)=21
32177              ISIG(NCHN,2)=21
32178              ISIG(NCHN,3)=3
32179              SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
32180           ENDIF
32181  
32182         ELSEIF(ISUB.EQ.424) THEN
32183 C...g + g -> QQ~[3PJ8] + g
32184           POLY=SH2+SH*TH+TH2
32185           IF(MSTP(145).EQ.0) THEN
32186             FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
32187      &            -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
32188      &            +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
32189      &            +7D0*TH**6)
32190      &            +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
32191      &            +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
32192      &            +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
32193      &            +35D0*TH**8)
32194      &            -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
32195      &            +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
32196      &            +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
32197      &            +84D0*TH**8)
32198      &            +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
32199      &            +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
32200      &            +451D0*SH*TH**5+126D0*TH**6)
32201      &            -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
32202      &            +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
32203      &            +171D0*SH*TH**5+42D0*TH**6)
32204      &            +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
32205      &            +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
32206      &            -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
32207      &            +99D0*SH*TH**3+35D0*TH**4)
32208      &            +7D0*SQMQQ**8*SHTH*POLY)/
32209      &            (SH*TH*UH*SQMQQR*SQMQQ*
32210      &            SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32211           ELSE
32212             FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
32213      &            *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32214             AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
32215      &           -SQMQQ*SHTH2*POLY**2*
32216      &           (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
32217      &           +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
32218      &           +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
32219      &           +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
32220      &           -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
32221      &           +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
32222      &           +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
32223      &           +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
32224      &           +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
32225      &           +145D0*SH*TH**5+34D0*TH**6)
32226      &           -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
32227      &           +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
32228      &           +44D0*TH**6)
32229      &           +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
32230      &           +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
32231      &           -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
32232      &           *(5D0*SH2+11D0*SH*TH+5D0*TH2)
32233      &           +3D0*SQMQQ**8*SHTH*POLY)
32234             BB=4D0*SHTH2*POLY**3
32235      &           *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
32236      &           -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
32237      &           +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
32238      &           +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
32239      &           +84D0*SH*TH**9+20D0*TH**10)
32240      &           +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
32241      &           +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
32242      &           +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
32243      &           +40D0*TH**8)
32244      &           -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
32245      &           -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
32246      &           -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
32247      &           +40D0*TH**8)
32248      &           +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
32249      &           -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
32250      &           -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
32251      &           -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
32252      &           -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
32253      &           +4D0*TH**6)
32254      &           -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
32255      &           +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
32256      &           +8D0*SQMQQ**7*SH*TH*SHTH*POLY
32257             CC=4D0*TH2*POLY**3
32258      &           *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
32259      &           -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
32260      &           +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
32261      &           +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
32262      &           +28D0*TH**9)
32263      &           +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
32264      &           -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
32265      &           +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
32266      &           +394D0*SH*TH**9+84D0*TH**10)
32267      &           -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
32268      &           +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
32269      &           +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
32270      &           +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
32271      &           +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
32272      &           +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
32273      &           -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
32274      &           +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
32275      &           +266D0*SH*TH**6+84D0*TH**7)
32276      &           +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
32277      &           -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
32278      &           +28D0*TH**6)
32279      &           -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
32280      &           +7D0*SH*TH**3+4*TH**4)
32281      &           +SQMQQ**8*SH*(SH-TH)**2*TH
32282             DD=2D0*TH2*SHTH2*POLY**3
32283      &           *(-SH2+2*SH*TH+2*TH2)
32284      &           +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
32285      &           +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
32286      &           -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
32287      &           -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
32288      &           -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
32289      &           +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
32290      &           -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
32291      &           -210D0*SH*TH**8-60D0*TH**9)
32292      &           +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
32293      &           +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
32294      &           -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
32295      &           -80D0*TH**8)
32296      &           -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
32297      &           +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
32298      &           -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
32299      &           +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
32300      &           +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
32301      &           -30D0*SH*TH**6-24D0*TH**7)
32302      &           -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
32303      &           +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
32304      &           -4D0*TH**6)
32305      &           +4D0*SQMQQ**7*SH*TH*SHTH*POLY
32306             IF(MSTP(147).EQ.0) THEN
32307                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32308      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32309             ELSEIF(MSTP(147).EQ.1) THEN
32310                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32311      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32312             ELSEIF(MSTP(147).EQ.3) THEN
32313                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32314      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32315             ELSEIF(MSTP(147).EQ.4) THEN
32316                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32317      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32318             ELSEIF(MSTP(147).EQ.5) THEN
32319                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32320      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32321             ELSEIF(MSTP(147).EQ.6) THEN
32322                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32323      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32324             ENDIF
32325             FACQQG=COMFAC*FF*FACQQG
32326           ENDIF
32327 C...Split total contribution into different colour flows just like
32328 C...in g g -> g g (recalculate kinematics for massless partons).
32329           THP=-0.5D0*SH*(1D0-CTH)
32330           UHP=-0.5D0*SH*(1D0+CTH)
32331           FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32332           FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32333           FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32334           FACGGS=FACGG1+FACGG2+FACGG3
32335           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32336              NCHN=NCHN+1
32337              ISIG(NCHN,1)=21
32338              ISIG(NCHN,2)=21
32339              ISIG(NCHN,3)=1
32340              SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32341              NCHN=NCHN+1
32342              ISIG(NCHN,1)=21
32343              ISIG(NCHN,2)=21
32344              ISIG(NCHN,3)=2
32345              SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32346              NCHN=NCHN+1
32347              ISIG(NCHN,1)=21
32348              ISIG(NCHN,2)=21
32349              ISIG(NCHN,3)=3
32350              SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
32351           ENDIF
32352  
32353         ELSEIF(ISUB.EQ.425) THEN
32354 C...q + g -> q + QQ~[3S18]
32355           IF(MSTP(145).EQ.0) THEN
32356             FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
32357      &            (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
32358      &            (SQMQQ*SQMQQR*SH*UH*UHSH2)
32359           ELSE
32360             FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
32361      &            (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
32362             AA=SHTH2+THUH2
32363             BB=4D0
32364             CC=8D0
32365             DD=4D0
32366             IF(MSTP(147).EQ.0) THEN
32367                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32368      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32369             ELSEIF(MSTP(147).EQ.1) THEN
32370                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32371      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32372             ELSEIF(MSTP(147).EQ.3) THEN
32373                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32374      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32375             ELSEIF(MSTP(147).EQ.4) THEN
32376                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32377      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32378             ELSEIF(MSTP(147).EQ.5) THEN
32379                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32380      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32381             ELSEIF(MSTP(147).EQ.6) THEN
32382                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32383      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32384             ENDIF
32385             FACQQG=COMFAC*FF*FACQQG
32386           ENDIF
32387 C...Split total contribution into different colour flows just like
32388 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32389 C...(recalculate kinematics for massless partons).
32390           THP=-0.5D0*SH*(1D0-CTH)
32391           UHP=-0.5D0*SH*(1D0+CTH)
32392           FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32393           FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32394           FACQGS=FACQG1+FACQG2
32395           DO 2442 I=MMINA,MMAXA
32396             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
32397             DO 2441 ISDE=1,2
32398               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
32399               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
32400               NCHN=NCHN+1
32401               ISIG(NCHN,ISDE)=I
32402               ISIG(NCHN,3-ISDE)=21
32403               ISIG(NCHN,3)=1
32404               SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
32405               NCHN=NCHN+1
32406               ISIG(NCHN,ISDE)=I
32407               ISIG(NCHN,3-ISDE)=21
32408               ISIG(NCHN,3)=2
32409               SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
32410  2441       CONTINUE
32411  2442     CONTINUE
32412  
32413         ELSEIF(ISUB.EQ.426) THEN
32414 C...q + g -> q + QQ~[1S08]
32415           IF(MSTP(145).EQ.0) THEN
32416             FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
32417      &            (SH2+UH2)/(SQMQQR*TH*UHSH2)
32418           ELSE
32419             FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
32420             IF(MSTP(147).EQ.0) THEN
32421                FACQQG=COMFAC*FA
32422             ELSEIF(MSTP(147).EQ.1) THEN
32423                FACQQG=COMFAC*2D0*FA
32424             ELSEIF(MSTP(147).EQ.3) THEN
32425                FACQQG=COMFAC*FA
32426             ELSEIF(MSTP(147).EQ.4) THEN
32427                FACQQG=COMFAC*FA
32428             ELSEIF(MSTP(147).EQ.5) THEN
32429                FACQQG=0D0
32430             ELSEIF(MSTP(147).EQ.6) THEN
32431                FACQQG=0D0
32432             ENDIF
32433           ENDIF
32434 C...Split total contribution into different colour flows just like
32435 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32436 C...(recalculate kinematics for massless partons).
32437           THP=-0.5D0*SH*(1D0-CTH)
32438           UHP=-0.5D0*SH*(1D0+CTH)
32439           FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32440           FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32441           FACQGS=FACQG1+FACQG2
32442           DO 2444 I=MMINA,MMAXA
32443             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
32444             DO 2443 ISDE=1,2
32445               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
32446               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
32447               NCHN=NCHN+1
32448               ISIG(NCHN,ISDE)=I
32449               ISIG(NCHN,3-ISDE)=21
32450               ISIG(NCHN,3)=1
32451               SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
32452               NCHN=NCHN+1
32453               ISIG(NCHN,ISDE)=I
32454               ISIG(NCHN,3-ISDE)=21
32455               ISIG(NCHN,3)=2
32456               SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
32457  2443       CONTINUE
32458  2444     CONTINUE
32459  
32460         ELSEIF(ISUB.EQ.427) THEN
32461 C...q + g -> q + QQ~[3PJ8]
32462           IF(MSTP(145).EQ.0) THEN
32463             FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
32464      &            ((7D0*UHSH+8D0*TH)*(SH2+UH2)
32465      &            +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
32466      &            (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
32467           ELSE
32468             FF=10D0*PARU(1)*AS**3/
32469      &            (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
32470             AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
32471             BB=8D0*(SHTH2+TH*UH)
32472             CC=8D0*UHSH*(SHTH+THUH)
32473             DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
32474             IF(MSTP(147).EQ.0) THEN
32475                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32476      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32477             ELSEIF(MSTP(147).EQ.1) THEN
32478                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32479      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32480             ELSEIF(MSTP(147).EQ.3) THEN
32481                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32482      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32483             ELSEIF(MSTP(147).EQ.4) THEN
32484                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32485      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32486             ELSEIF(MSTP(147).EQ.5) THEN
32487                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32488      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32489             ELSEIF(MSTP(147).EQ.6) THEN
32490                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32491      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32492             ENDIF
32493             FACQQG=COMFAC*FF*FACQQG
32494           ENDIF
32495 C...Split total contribution into different colour flows just like
32496 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32497 C...(recalculate kinematics for massless partons).
32498           THP=-0.5D0*SH*(1D0-CTH)
32499           UHP=-0.5D0*SH*(1D0+CTH)
32500           FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32501           FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32502           FACQGS=FACQG1+FACQG2
32503           DO 2446 I=MMINA,MMAXA
32504             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
32505             DO 2445 ISDE=1,2
32506               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
32507               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
32508               NCHN=NCHN+1
32509               ISIG(NCHN,ISDE)=I
32510               ISIG(NCHN,3-ISDE)=21
32511               ISIG(NCHN,3)=1
32512               SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
32513               NCHN=NCHN+1
32514               ISIG(NCHN,ISDE)=I
32515               ISIG(NCHN,3-ISDE)=21
32516               ISIG(NCHN,3)=2
32517               SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
32518  2445       CONTINUE
32519  2446     CONTINUE
32520  
32521         ELSEIF(ISUB.EQ.428) THEN
32522 C...q + q~ -> g + QQ~[3S18]
32523           IF(MSTP(145).EQ.0) THEN
32524             FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
32525      &            (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
32526      &            (SQMQQ*SQMQQR*TH*UH*THUH2)
32527           ELSE
32528             FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
32529      &            (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
32530             AA=SHTH2+UHSH2
32531             BB=4D0
32532             CC=4D0
32533             DD=0D0
32534             IF(MSTP(147).EQ.0) THEN
32535                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32536      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32537             ELSEIF(MSTP(147).EQ.1) THEN
32538                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32539      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32540             ELSEIF(MSTP(147).EQ.3) THEN
32541                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32542      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32543             ELSEIF(MSTP(147).EQ.4) THEN
32544                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32545      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32546             ELSEIF(MSTP(147).EQ.5) THEN
32547                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32548      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32549             ELSEIF(MSTP(147).EQ.6) THEN
32550                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32551      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32552             ENDIF
32553             FACQQG=COMFAC*FF*FACQQG
32554           ENDIF
32555 C...Split total contribution into different colour flows just like
32556 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32557 C...(recalculate kinematics for massless partons).
32558           THP=-0.5D0*SH*(1D0-CTH)
32559           UHP=-0.5D0*SH*(1D0+CTH)
32560           FACGG1=UH/TH-9D0/4D0*UH2/SH2
32561           FACGG2=TH/UH-9D0/4D0*TH2/SH2
32562           FACGGS=FACGG1+FACGG2
32563           DO 2447 I=MMINA,MMAXA
32564             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32565      &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
32566             NCHN=NCHN+1
32567             ISIG(NCHN,1)=I
32568             ISIG(NCHN,2)=-I
32569             ISIG(NCHN,3)=1
32570             SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32571             NCHN=NCHN+1
32572             ISIG(NCHN,1)=I
32573             ISIG(NCHN,2)=-I
32574             ISIG(NCHN,3)=2
32575             SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32576  2447     CONTINUE
32577  
32578         ELSEIF(ISUB.EQ.429) THEN
32579 C...q + q~ -> g + QQ~[1S08]
32580           IF(MSTP(145).EQ.0) THEN
32581             FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
32582      &            (TH2+UH2)/(SQMQQR*SH*THUH2)
32583           ELSE
32584             FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
32585             IF(MSTP(147).EQ.0) THEN
32586                FACQQG=COMFAC*FA
32587             ELSEIF(MSTP(147).EQ.1) THEN
32588                FACQQG=COMFAC*2D0*FA
32589             ELSEIF(MSTP(147).EQ.3) THEN
32590                FACQQG=COMFAC*FA
32591             ELSEIF(MSTP(147).EQ.4) THEN
32592                FACQQG=COMFAC*FA
32593             ELSEIF(MSTP(147).EQ.5) THEN
32594                FACQQG=0D0
32595             ELSEIF(MSTP(147).EQ.6) THEN
32596                FACQQG=0D0
32597             ENDIF
32598           ENDIF
32599 C...Split total contribution into different colour flows just like
32600 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32601 C...(recalculate kinematics for massless partons).
32602           THP=-0.5D0*SH*(1D0-CTH)
32603           UHP=-0.5D0*SH*(1D0+CTH)
32604           FACGG1=UH/TH-9D0/4D0*UH2/SH2
32605           FACGG2=TH/UH-9D0/4D0*TH2/SH2
32606           FACGGS=FACGG1+FACGG2
32607           DO 2448 I=MMINA,MMAXA
32608             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32609      &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
32610             NCHN=NCHN+1
32611             ISIG(NCHN,1)=I
32612             ISIG(NCHN,2)=-I
32613             ISIG(NCHN,3)=1
32614             SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32615             NCHN=NCHN+1
32616             ISIG(NCHN,1)=I
32617             ISIG(NCHN,2)=-I
32618             ISIG(NCHN,3)=2
32619             SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32620  2448     CONTINUE
32621  
32622         ELSEIF(ISUB.EQ.430) THEN
32623 C...q + q~ -> g + QQ~[3PJ8]
32624           IF(MSTP(145).EQ.0) THEN
32625             FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
32626      &            ((7D0*THUH+8D0*SH)*(TH2+UH2)
32627      &            +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
32628      &            (SQMQQ*SQMQQR*SH*THUH2*THUH)
32629           ELSE
32630             FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
32631             AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
32632             BB=8D0*(UHSH2+SH*TH)
32633             CC=8D0*(SHTH2+SH*UH)
32634             DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
32635             IF(MSTP(147).EQ.0) THEN
32636                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32637      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32638             ELSEIF(MSTP(147).EQ.1) THEN
32639                FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32640      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32641             ELSEIF(MSTP(147).EQ.3) THEN
32642                FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32643      &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32644             ELSEIF(MSTP(147).EQ.4) THEN
32645                FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32646      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32647             ELSEIF(MSTP(147).EQ.5) THEN
32648                FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32649      &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32650             ELSEIF(MSTP(147).EQ.6) THEN
32651                FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32652      &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32653             ENDIF
32654             FACQQG=COMFAC*FF*FACQQG
32655           ENDIF
32656 C...Split total contribution into different colour flows just like
32657 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32658 C...(recalculate kinematics for massless partons).
32659           THP=-0.5D0*SH*(1D0-CTH)
32660           UHP=-0.5D0*SH*(1D0+CTH)
32661           FACGG1=UH/TH-9D0/4D0*UH2/SH2
32662           FACGG2=TH/UH-9D0/4D0*TH2/SH2
32663           FACGGS=FACGG1+FACGG2
32664           DO 2449 I=MMINA,MMAXA
32665             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32666      &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32667             NCHN=NCHN+1
32668             ISIG(NCHN,1)=I
32669             ISIG(NCHN,2)=-I
32670             ISIG(NCHN,3)=1
32671             SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32672             NCHN=NCHN+1
32673             ISIG(NCHN,1)=I
32674             ISIG(NCHN,2)=-I
32675             ISIG(NCHN,3)=2
32676             SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32677  2449     CONTINUE
32678  
32679         ELSEIF(ISUB.EQ.431) THEN
32680 C...g + g -> QQ~[3P01] + g
32681           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32682           QGTW=(SH*TH*UH)/SH**3
32683           RGTW=SQMQQ/SH
32684           IF(MSTP(145).EQ.0) THEN
32685             FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32686      &            (9D0*RGTW**2*PGTW**4*
32687      &            (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32688      &            -6D0*RGTW*PGTW**3*QGTW*
32689      &            (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32690      &            -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32691      &            +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32692      &            +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32693           ELSE
32694             FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32695      &            (9D0*RGTW**2*PGTW**4*
32696      &            (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32697      &            -6D0*RGTW*PGTW**3*QGTW*
32698      &            (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32699      &            -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32700      &            +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32701      &            +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32702             IF(MSTP(147).EQ.0) THEN
32703                FACQQG=COMFAC*FC1
32704             ELSEIF(MSTP(147).EQ.1) THEN
32705                FACQQG=COMFAC*2D0*FC1
32706             ELSEIF(MSTP(147).EQ.3) THEN
32707                FACQQG=COMFAC*FC1
32708             ELSEIF(MSTP(147).EQ.4) THEN
32709                FACQQG=COMFAC*FC1
32710             ELSEIF(MSTP(147).EQ.5) THEN
32711                FACQQG=0D0
32712             ELSEIF(MSTP(147).EQ.6) THEN
32713                FACQQG=0D0
32714             ENDIF
32715           ENDIF
32716           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32717             NCHN=NCHN+1
32718             ISIG(NCHN,1)=21
32719             ISIG(NCHN,2)=21
32720             ISIG(NCHN,3)=1
32721             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32722           ENDIF
32723  
32724         ELSEIF(ISUB.EQ.432) THEN
32725 C...g + g -> QQ~[3P11] + g
32726           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32727           QGTW=(SH*TH*UH)/SH**3
32728           RGTW=SQMQQ/SH
32729           IF(MSTP(145).EQ.0) THEN
32730             FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32731      &            PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32732      &            +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32733      &            -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32734           ELSE
32735             FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32736             C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32737      &            +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32738      &            -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32739      &            +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32740             C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32741      &            -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32742      &            *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32743             C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32744      &            -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32745      &            *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32746             C4=-4D0*THUH*(TH-UH)**2*
32747      &            (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32748      &            -SH2*TH*UH*(TH2+UH2))
32749      &            +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32750      &            -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32751      &            +SH2*(5D0*THUH2-17D0*TH*UH)))
32752             IF(MSTP(147).EQ.0) THEN
32753                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32754      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32755             ELSEIF(MSTP(147).EQ.1) THEN
32756                FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32757      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32758             ELSEIF(MSTP(147).EQ.3) THEN
32759                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32760      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32761             ELSEIF(MSTP(147).EQ.4) THEN
32762                FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32763      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32764             ELSEIF(MSTP(147).EQ.5) THEN
32765                FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32766      &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32767             ELSEIF(MSTP(147).EQ.6) THEN
32768                FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32769      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32770             ENDIF
32771             FACQQG=COMFAC*FF*FACQQG
32772           ENDIF
32773           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32774             NCHN=NCHN+1
32775             ISIG(NCHN,1)=21
32776             ISIG(NCHN,2)=21
32777             ISIG(NCHN,3)=1
32778             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32779           ENDIF
32780  
32781         ELSEIF(ISUB.EQ.433) THEN
32782 C...g + g -> QQ~[3P21] + g
32783           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32784           QGTW=(SH*TH*UH)/SH**3
32785           RGTW=SQMQQ/SH
32786           IF(MSTP(145).EQ.0) THEN
32787             FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32788      &            (12D0*RGTW**2*PGTW**4*
32789      &            (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32790      &            -3D0*RGTW*PGTW**3*QGTW*
32791      &            (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32792      &            +2D0*PGTW**2*QGTW**2*
32793      &            (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32794      &            +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32795      &            +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32796           ELSE
32797             FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32798      &            (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32799             C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32800      &            *SH*SH2**7
32801             C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32802      &            +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32803      &            +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32804      &            +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32805      &            +10D0*(SH2**2+TH2**2))
32806      &            +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32807      &            -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32808      &            -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32809      &            +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32810      &            +4D0*SH*TH*UH2**4*SHTH2)
32811             C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32812      &            +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32813      &            +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32814      &            +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32815      &            +10D0*(SH2**2+UH2**2))
32816      &            +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32817      &            -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32818      &            -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32819      &            +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32820      &            +4D0*SH*UH*TH2**4*UHSH2)
32821             C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32822      &            -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32823      &            +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32824      &            -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32825      &            -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32826      &            -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32827      &            +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32828      &            -SH2**2*TH*UH*(114D0*TH**3*UH**3
32829      &            +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32830      &            +3D0*(TH2**3+UH2**3)))
32831             C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32832      &            *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32833             C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32834      &            *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32835             C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32836      &            +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32837      &            +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32838      &            82D0*TH**3)
32839      &            +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32840      &            +45D0*TH**3)
32841      &            +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32842      &            8D0*TH**3)
32843      &            +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32844      &            +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32845      &            +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32846             C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32847      &            +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32848      &            +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32849      &            82D0*UH**3)
32850      &            +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32851      &            +45D0*UH**3)
32852      &            +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32853      &            8D0*UH**3)
32854      &            +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32855      &            +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32856      &            +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32857             C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32858      &            +4D0*SH*TH2**2*UH2**2*THUH2
32859      &            -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32860      &            -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32861      &            +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32862      &            +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32863      &            +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32864             C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32865      &            -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32866      &            -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32867      &            -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32868      &            +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32869      &            +SH**5*TH*UH*(-428D0*TH**3*UH**3
32870      &            -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32871      &            +2D0*(TH2**3+UH2**3))
32872      &            +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32873      &            +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32874      &            +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32875      &            +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32876             IF(MSTP(147).EQ.0) THEN
32877                FACQQG=1D0/3D0*(C1*3D0
32878      &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32879      &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32880      &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32881      &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32882      &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32883      &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32884      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
32885      &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32886      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
32887      &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32888      &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
32889      &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32890             ELSEIF(MSTP(147).EQ.1) THEN
32891                FACQQG=C1*2D0
32892      &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32893      &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32894      &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32895      &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32896      &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32897      &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32898      &                      +EL1K10*EL2K20*EL1K11*EL2K11)
32899      &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32900      &                      +EL1K10*EL2K20*EL1K21*EL2K21)
32901      &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32902      &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32903      &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32904      &                  +EL1K20*EL2K20*EL1K11*EL2K11)
32905             ELSEIF(MSTP(147).EQ.2) THEN
32906                FACQQG=2D0*(C1
32907      &              -C2*EL1K11*EL2K11
32908      &              -C3*EL1K21*EL2K21
32909      &              -C4*EL1K11*EL2K21
32910      &              +C5*(EL1K11*EL2K11)**2
32911      &              +C6*(EL1K21*EL2K21)**2
32912      &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
32913      &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
32914      &              +(C9+C0)*(EL1K11*EL2K21)**2)
32915             ENDIF
32916             FACQQG=COMFAC*FF*FACQQG
32917           ENDIF
32918           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32919             NCHN=NCHN+1
32920             ISIG(NCHN,1)=21
32921             ISIG(NCHN,2)=21
32922             ISIG(NCHN,3)=1
32923             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32924           ENDIF
32925  
32926         ELSEIF(ISUB.EQ.434) THEN
32927 C...q + g -> q + QQ~[3P01]
32928           IF(MSTP(145).EQ.0) THEN
32929             FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32930      &            (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32931           ELSE
32932             FA=-PARU(1)*AS**3*(16D0/243D0)*
32933      &            (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32934             IF(MSTP(147).EQ.0) THEN
32935                FACQQG=COMFAC*FA
32936             ELSEIF(MSTP(147).EQ.1) THEN
32937                FACQQG=COMFAC*2D0*FA
32938             ELSEIF(MSTP(147).EQ.3) THEN
32939                FACQQG=COMFAC*FA
32940             ELSEIF(MSTP(147).EQ.4) THEN
32941                FACQQG=COMFAC*FA
32942             ELSEIF(MSTP(147).EQ.5) THEN
32943                FACQQG=0D0
32944             ELSEIF(MSTP(147).EQ.6) THEN
32945                FACQQG=0D0
32946             ENDIF
32947           ENDIF
32948           DO 2452 I=MMINA,MMAXA
32949             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32950             DO 2451 ISDE=1,2
32951               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32952               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32953               NCHN=NCHN+1
32954               ISIG(NCHN,ISDE)=I
32955               ISIG(NCHN,3-ISDE)=21
32956               ISIG(NCHN,3)=1
32957               SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32958  2451       CONTINUE
32959  2452     CONTINUE
32960  
32961         ELSEIF(ISUB.EQ.435) THEN
32962 C...q + g -> q + QQ~[3P11]
32963           IF(MSTP(145).EQ.0) THEN
32964             FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32965      &            (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32966           ELSE
32967             FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32968             C1=SH*UH
32969             C2=2D0*SH
32970             C3=0D0
32971             C4=2D0*(SH-UH)
32972             IF(MSTP(147).EQ.0) THEN
32973                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32974      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32975             ELSEIF(MSTP(147).EQ.1) THEN
32976                FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32977      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32978             ELSEIF(MSTP(147).EQ.3) THEN
32979                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32980      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32981             ELSEIF(MSTP(147).EQ.4) THEN
32982                FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32983      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32984             ELSEIF(MSTP(147).EQ.5) THEN
32985                FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32986      &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32987             ELSEIF(MSTP(147).EQ.6) THEN
32988                FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32989      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32990             ENDIF
32991             FACQQG=COMFAC*FF*FACQQG
32992           ENDIF
32993           DO 2454 I=MMINA,MMAXA
32994             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32995             DO 2453 ISDE=1,2
32996               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32997               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32998               NCHN=NCHN+1
32999               ISIG(NCHN,ISDE)=I
33000               ISIG(NCHN,3-ISDE)=21
33001               ISIG(NCHN,3)=1
33002               SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33003  2453       CONTINUE
33004  2454     CONTINUE
33005  
33006         ELSEIF(ISUB.EQ.436) THEN
33007 C...q + g -> q + QQ~[3P21]
33008           IF(MSTP(145).EQ.0) THEN
33009             FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
33010      &            ((6D0*SQMQQ**2+TH2)*UHSH2
33011      &            -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
33012      &            (SQMQQR*TH*UHSH2**2)
33013           ELSE
33014             FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
33015             C1=TH*UHSH2
33016             C2=4D0*(SH2+TH2+2D0*TH*UHSH)
33017             C3=4D0*UHSH2
33018             C4=8D0*SH*UHSH
33019             C5=8D0*TH
33020             C6=0D0
33021             C7=16D0*TH
33022             C8=0D0
33023             C9=-16D0*UHSH
33024             C0=16D0*SQMQQ
33025             IF(MSTP(147).EQ.0) THEN
33026                FACQQG=1D0/3D0*(C1*3D0
33027      &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33028      &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33029      &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33030      &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33031      &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33032      &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33033      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
33034      &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33035      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
33036      &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33037      &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
33038      &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33039             ELSEIF(MSTP(147).EQ.1) THEN
33040                FACQQG=C1*2D0
33041      &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33042      &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33043      &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33044      &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33045      &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33046      &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33047      &                      +EL1K10*EL2K20*EL1K11*EL2K11)
33048      &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33049      &                      +EL1K10*EL2K20*EL1K21*EL2K21)
33050      &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33051      &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33052      &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33053      &                  +EL1K20*EL2K20*EL1K11*EL2K11)
33054             ELSEIF(MSTP(147).EQ.2) THEN
33055                FACQQG=2D0*(C1
33056      &              -C2*EL1K11*EL2K11
33057      &              -C3*EL1K21*EL2K21
33058      &              -C4*EL1K11*EL2K21
33059      &              +C5*(EL1K11*EL2K11)**2
33060      &              +C6*(EL1K21*EL2K21)**2
33061      &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
33062      &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
33063      &              +(C9+C0)*(EL1K11*EL2K21)**2)
33064             ENDIF
33065             FACQQG=COMFAC*FF*FACQQG
33066           ENDIF
33067           DO 2456 I=MMINA,MMAXA
33068             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
33069             DO 2455 ISDE=1,2
33070               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
33071               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
33072               NCHN=NCHN+1
33073               ISIG(NCHN,ISDE)=I
33074               ISIG(NCHN,3-ISDE)=21
33075               ISIG(NCHN,3)=1
33076               SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33077  2455       CONTINUE
33078  2456     CONTINUE
33079  
33080         ELSEIF(ISUB.EQ.437) THEN
33081 C...q + q~ -> g + QQ~[3P01]
33082           IF(MSTP(145).EQ.0) THEN
33083             FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
33084      &            (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33085           ELSE
33086             FA=PARU(1)*AS**3*(128D0/729D0)*
33087      &            (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33088             IF(MSTP(147).EQ.0) THEN
33089                FACQQG=COMFAC*FA
33090             ELSEIF(MSTP(147).EQ.1) THEN
33091                FACQQG=COMFAC*2D0*FA
33092             ELSEIF(MSTP(147).EQ.3) THEN
33093                FACQQG=COMFAC*FA
33094             ELSEIF(MSTP(147).EQ.4) THEN
33095                FACQQG=COMFAC*FA
33096             ELSEIF(MSTP(147).EQ.5) THEN
33097                FACQQG=0D0
33098             ELSEIF(MSTP(147).EQ.6) THEN
33099                FACQQG=0D0
33100             ENDIF
33101           ENDIF
33102           DO 2457 I=MMINA,MMAXA
33103             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33104      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
33105             NCHN=NCHN+1
33106             ISIG(NCHN,1)=I
33107             ISIG(NCHN,2)=-I
33108             ISIG(NCHN,3)=1
33109             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33110  2457     CONTINUE
33111  
33112         ELSEIF(ISUB.EQ.438) THEN
33113 C...q + q~ -> g + QQ~[3P11]
33114           IF(MSTP(145).EQ.0) THEN
33115             FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
33116      &            (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
33117           ELSE
33118             FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
33119             C1=TH*UH
33120             C2=2D0*UH
33121             C3=2D0*TH
33122             C4=2D0*THUH
33123             IF(MSTP(147).EQ.0) THEN
33124                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33125      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33126             ELSEIF(MSTP(147).EQ.1) THEN
33127                FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33128      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
33129             ELSEIF(MSTP(147).EQ.3) THEN
33130                FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33131      &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33132             ELSEIF(MSTP(147).EQ.4) THEN
33133                FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33134      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33135             ELSEIF(MSTP(147).EQ.5) THEN
33136                FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
33137      &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
33138             ELSEIF(MSTP(147).EQ.6) THEN
33139                FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33140      &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33141             ENDIF
33142             FACQQG=COMFAC*FF*FACQQG
33143           ENDIF
33144           DO 2458 I=MMINA,MMAXA
33145             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33146      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
33147             NCHN=NCHN+1
33148             ISIG(NCHN,1)=I
33149             ISIG(NCHN,2)=-I
33150             ISIG(NCHN,3)=1
33151             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33152  2458     CONTINUE
33153  
33154         ELSEIF(ISUB.EQ.439) THEN
33155 C...q + q~ -> g + QQ~[3P21]
33156           IF(MSTP(145).EQ.0) THEN
33157             FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
33158      &            ((6D0*SQMQQ**2+SH2)*THUH2
33159      &            -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
33160      &            (SQMQQR*SH*THUH2**2)
33161           ELSE
33162             FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
33163             C1=SH*THUH2
33164             C2=4D0*(SH2+UH2+2D0*SH*THUH)
33165             C3=4D0*(SH2+TH2+2D0*SH*THUH)
33166             C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
33167             C5=8D0*SH
33168             C6=C5
33169             C7=16D0*SH
33170             C8=C7
33171             C9=-16D0*THUH
33172             C0=16D0*SQMQQ
33173             IF(MSTP(147).EQ.0) THEN
33174                FACQQG=1D0/3D0*(C1*3D0
33175      &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33176      &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33177      &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33178      &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33179      &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33180      &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33181      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
33182      &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33183      &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
33184      &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33185      &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
33186      &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33187             ELSEIF(MSTP(147).EQ.1) THEN
33188                FACQQG=C1*2D0
33189      &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33190      &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33191      &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33192      &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33193      &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33194      &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33195      &                      +EL1K10*EL2K20*EL1K11*EL2K11)
33196      &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33197      &                      +EL1K10*EL2K20*EL1K21*EL2K21)
33198      &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33199      &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33200      &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33201      &                  +EL1K20*EL2K20*EL1K11*EL2K11)
33202             ELSEIF(MSTP(147).EQ.2) THEN
33203                FACQQG=2D0*(C1
33204      &              -C2*EL1K11*EL2K11
33205      &              -C3*EL1K21*EL2K21
33206      &              -C4*EL1K11*EL2K21
33207      &              +C5*(EL1K11*EL2K11)**2
33208      &              +C6*(EL1K21*EL2K21)**2
33209      &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
33210      &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
33211      &              +(C9+C0)*(EL1K11*EL2K21)**2)
33212             ENDIF
33213             FACQQG=COMFAC*FF*FACQQG
33214           ENDIF
33215           DO 2459 I=MMINA,MMAXA
33216             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33217      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
33218             NCHN=NCHN+1
33219             ISIG(NCHN,1)=I
33220             ISIG(NCHN,2)=-I
33221             ISIG(NCHN,3)=1
33222             SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33223  2459     CONTINUE
33224         ENDIF
33225 C...QUARKONIA---
33226  
33227       ENDIF
33228  
33229       RETURN
33230       END
33231  
33232 C*********************************************************************
33233  
33234 C...PYSGWZ
33235 C...Subprocess cross sections for W/Z processes,
33236 C...except that longitudinal WW scattering is in Higgs sector.
33237 C...Auxiliary to PYSIGH.
33238  
33239       SUBROUTINE PYSGWZ(NCHN,SIGS)
33240  
33241 C...Double precision and integer declarations
33242       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33243       IMPLICIT INTEGER(I-N)
33244       INTEGER PYK,PYCHGE,PYCOMP
33245 C...Parameter statement to help give large particle numbers.
33246       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33247      &KEXCIT=4000000,KDIMEN=5000000)
33248 C...Commonblocks
33249       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33250       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33251       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33252       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33253       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33254       COMMON/PYINT1/MINT(400),VINT(400)
33255       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33256       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33257       COMMON/PYINT4/MWID(500),WIDS(500,5)
33258       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
33259       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33260      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33261      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33262      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33263       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
33264      &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
33265 C...Local arrays and complex numbers
33266       DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
33267      &HL4(3),HR4(3)
33268       COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
33269  
33270 C...Differential cross section expressions.
33271  
33272       IF(ISUB.LE.20) THEN
33273         IF(ISUB.EQ.1) THEN
33274 C...f + fbar -> gamma*/Z0
33275           MINT(61)=2
33276           CALL PYWIDT(23,SH,WDTP,WDTE)
33277           HS=SHR*WDTP(0)
33278           FACZ=4D0*COMFAC*3D0
33279           HP0=AEM/3D0*SH
33280           HP1=AEM/3D0*XWC*SH
33281           DO 100 I=MMINA,MMAXA
33282             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33283             EI=KCHG(IABS(I),1)/3D0
33284             AI=SIGN(1D0,EI)
33285             VI=AI-4D0*EI*XWV
33286             HI0=HP0
33287             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
33288             HI1=HP1
33289             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
33290             NCHN=NCHN+1
33291             ISIG(NCHN,1)=I
33292             ISIG(NCHN,2)=-I
33293             ISIG(NCHN,3)=1
33294             SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
33295      &      EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
33296      &      (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
33297      &      ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
33298   100     CONTINUE
33299  
33300         ELSEIF(ISUB.EQ.2) THEN
33301 C...f + fbar' -> W+/-
33302           CALL PYWIDT(24,SH,WDTP,WDTE)
33303           HS=SHR*WDTP(0)
33304           FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
33305           HP=AEM/(24D0*XW)*SH
33306           DO 120 I=MMIN1,MMAX1
33307             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33308             IA=IABS(I)
33309             DO 110 J=MMIN2,MMAX2
33310               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33311               JA=IABS(J)
33312               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
33313               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33314      &        GOTO 110
33315               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33316               HI=HP*2D0
33317               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
33318               NCHN=NCHN+1
33319               ISIG(NCHN,1)=I
33320               ISIG(NCHN,2)=J
33321               ISIG(NCHN,3)=1
33322               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
33323               SIGH(NCHN)=HI*FACBW*HF
33324   110       CONTINUE
33325   120     CONTINUE
33326  
33327         ELSEIF(ISUB.EQ.15) THEN
33328 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
33329           FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33330 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33331           HFGG=0D0
33332           HFGZ=0D0
33333           HFZZ=0D0
33334           RADC4=1D0+PYALPS(SQM4)/PARU(1)
33335           DO 130 I=1,MIN(16,MDCY(23,3))
33336             IDC=I+MDCY(23,2)-1
33337             IF(MDME(IDC,1).LT.0) GOTO 130
33338             IMDM=0
33339             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33340      &      IMDM=1
33341             IF(I.LE.8) THEN
33342               EF=KCHG(I,1)/3D0
33343               AF=SIGN(1D0,EF+0.1D0)
33344               VF=AF-4D0*EF*XWV
33345             ELSEIF(I.LE.16) THEN
33346               EF=KCHG(I+2,1)/3D0
33347               AF=SIGN(1D0,EF+0.1D0)
33348               VF=AF-4D0*EF*XWV
33349             ENDIF
33350             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33351             IF(4D0*RM1.LT.1D0) THEN
33352               FCOF=1D0
33353               IF(I.LE.8) FCOF=3D0*RADC4
33354               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33355               IF(IMDM.EQ.1) THEN
33356                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33357                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33358                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33359      &          AF**2*(1D0-4D0*RM1))*BE34
33360               ENDIF
33361             ENDIF
33362   130     CONTINUE
33363 C...Propagators: as simulated in PYOFSH and as desired
33364           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33365           MINT15=MINT(15)
33366           MINT(15)=1
33367           MINT(61)=1
33368           CALL PYWIDT(23,SQM4,WDTP,WDTE)
33369           MINT(15)=MINT15
33370           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33371           HFGG=HFGG*HFAEM*VINT(111)/SQM4
33372           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33373           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33374 C...Loop over flavours; consider full gamma/Z structure
33375           DO 140 I=MMINA,MMAXA
33376             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33377      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
33378             EI=KCHG(IABS(I),1)/3D0
33379             AI=SIGN(1D0,EI)
33380             VI=AI-4D0*EI*XWV
33381             NCHN=NCHN+1
33382             ISIG(NCHN,1)=I
33383             ISIG(NCHN,2)=-I
33384             ISIG(NCHN,3)=1
33385             SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
33386      &      (VI**2+AI**2)*HFZZ)/HBW4
33387   140     CONTINUE
33388  
33389         ELSEIF(ISUB.EQ.16) THEN
33390 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
33391           FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33392 C...Propagators: as simulated in PYOFSH and as desired
33393           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33394           CALL PYWIDT(24,SQM4,WDTP,WDTE)
33395           GMMWC=SQRT(SQM4)*WDTP(0)
33396           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33397           FACWG=FACWG*HBW4C/HBW4
33398           DO 160 I=MMIN1,MMAX1
33399             IA=IABS(I)
33400             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
33401             DO 150 J=MMIN2,MMAX2
33402               JA=IABS(J)
33403               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
33404               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
33405               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33406               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33407               FCKM=VCKM((IA+1)/2,(JA+1)/2)
33408               NCHN=NCHN+1
33409               ISIG(NCHN,1)=I
33410               ISIG(NCHN,2)=J
33411               ISIG(NCHN,3)=1
33412               SIGH(NCHN)=FACWG*FCKM*WIDSC
33413   150       CONTINUE
33414   160     CONTINUE
33415  
33416         ELSEIF(ISUB.EQ.19) THEN
33417 C...f + fbar -> gamma + (gamma*/Z0)
33418           FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33419 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33420           HFGG=0D0
33421           HFGZ=0D0
33422           HFZZ=0D0
33423           RADC4=1D0+PYALPS(SQM4)/PARU(1)
33424           DO 170 I=1,MIN(16,MDCY(23,3))
33425             IDC=I+MDCY(23,2)-1
33426             IF(MDME(IDC,1).LT.0) GOTO 170
33427             IMDM=0
33428             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33429      &      IMDM=1
33430             IF(I.LE.8) THEN
33431               EF=KCHG(I,1)/3D0
33432               AF=SIGN(1D0,EF+0.1D0)
33433               VF=AF-4D0*EF*XWV
33434             ELSEIF(I.LE.16) THEN
33435               EF=KCHG(I+2,1)/3D0
33436               AF=SIGN(1D0,EF+0.1D0)
33437               VF=AF-4D0*EF*XWV
33438             ENDIF
33439             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33440             IF(4D0*RM1.LT.1D0) THEN
33441               FCOF=1D0
33442               IF(I.LE.8) FCOF=3D0*RADC4
33443               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33444               IF(IMDM.EQ.1) THEN
33445                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33446                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33447                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33448      &          AF**2*(1D0-4D0*RM1))*BE34
33449               ENDIF
33450             ENDIF
33451   170     CONTINUE
33452 C...Propagators: as simulated in PYOFSH and as desired
33453           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33454           MINT15=MINT(15)
33455           MINT(15)=1
33456           MINT(61)=1
33457           CALL PYWIDT(23,SQM4,WDTP,WDTE)
33458           MINT(15)=MINT15
33459           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33460           HFGG=HFGG*HFAEM*VINT(111)/SQM4
33461           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33462           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33463 C...Loop over flavours; consider full gamma/Z structure
33464           DO 180 I=MMINA,MMAXA
33465             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
33466             EI=KCHG(IABS(I),1)/3D0
33467             AI=SIGN(1D0,EI)
33468             VI=AI-4D0*EI*XWV
33469             FCOI=1D0
33470             IF(IABS(I).LE.10) FCOI=FACA/3D0
33471             NCHN=NCHN+1
33472             ISIG(NCHN,1)=I
33473             ISIG(NCHN,2)=-I
33474             ISIG(NCHN,3)=1
33475             SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33476      &      (VI**2+AI**2)*HFZZ)/HBW4
33477   180     CONTINUE
33478  
33479         ELSEIF(ISUB.EQ.20) THEN
33480 C...f + fbar' -> gamma + W+/-
33481           FACGW=COMFAC*0.5D0*AEM**2/XW
33482 C...Propagators: as simulated in PYOFSH and as desired
33483           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33484           CALL PYWIDT(24,SQM4,WDTP,WDTE)
33485           GMMWC=SQRT(SQM4)*WDTP(0)
33486           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33487           FACGW=FACGW*HBW4C/HBW4
33488 C...Anomalous couplings
33489           TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33490           TERM2=0D0
33491           TERM3=0D0
33492           IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
33493             TERM2=RTCM(46)*(TH-UH)/(TH+UH)
33494             TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
33495      &      (4D0*SQMW))/(TH+UH)**2
33496           ENDIF
33497           DO 200 I=MMIN1,MMAX1
33498             IA=IABS(I)
33499             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
33500             DO 190 J=MMIN2,MMAX2
33501               JA=IABS(J)
33502               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
33503               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
33504               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33505      &        GOTO 190
33506               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33507               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33508               IF(IA.LE.10) THEN
33509                 FACWR=UH/(TH+UH)-1D0/3D0
33510                 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33511                 FCOI=FACA/3D0
33512               ELSE
33513                 FACWR=-TH/(TH+UH)
33514                 FCKM=1D0
33515                 FCOI=1D0
33516               ENDIF
33517               FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
33518               NCHN=NCHN+1
33519               ISIG(NCHN,1)=I
33520               ISIG(NCHN,2)=J
33521               ISIG(NCHN,3)=1
33522               SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
33523   190       CONTINUE
33524   200     CONTINUE
33525         ENDIF
33526  
33527       ELSEIF(ISUB.LE.40) THEN
33528         IF(ISUB.EQ.22) THEN
33529 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
33530 C...Kinematics dependence
33531           FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
33532      &    SQM3*SQM4*(1D0/TH2+1D0/UH2))
33533 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33534           DO 220 I=1,6
33535             DO 210 J=1,3
33536               HGZ(I,J)=0D0
33537   210       CONTINUE
33538   220     CONTINUE
33539           RADC3=1D0+PYALPS(SQM3)/PARU(1)
33540           RADC4=1D0+PYALPS(SQM4)/PARU(1)
33541           DO 230 I=1,MIN(16,MDCY(23,3))
33542             IDC=I+MDCY(23,2)-1
33543             IF(MDME(IDC,1).LT.0) GOTO 230
33544             IMDM=0
33545             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
33546             IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
33547             IF(I.LE.8) THEN
33548               EF=KCHG(I,1)/3D0
33549               AF=SIGN(1D0,EF+0.1D0)
33550               VF=AF-4D0*EF*XWV
33551             ELSEIF(I.LE.16) THEN
33552               EF=KCHG(I+2,1)/3D0
33553               AF=SIGN(1D0,EF+0.1D0)
33554               VF=AF-4D0*EF*XWV
33555             ENDIF
33556             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
33557             IF(4D0*RM1.LT.1D0) THEN
33558               FCOF=1D0
33559               IF(I.LE.8) FCOF=3D0*RADC3
33560               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33561               IF(IMDM.GE.1) THEN
33562                 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33563                 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33564                 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33565      &          AF**2*(1D0-4D0*RM1))*BE34
33566               ENDIF
33567             ENDIF
33568             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33569             IF(4D0*RM1.LT.1D0) THEN
33570               FCOF=1D0
33571               IF(I.LE.8) FCOF=3D0*RADC4
33572               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33573               IF(IMDM.GE.1) THEN
33574                 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33575                 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33576                 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33577      &          AF**2*(1D0-4D0*RM1))*BE34
33578               ENDIF
33579             ENDIF
33580   230     CONTINUE
33581 C...Propagators: as simulated in PYOFSH and as desired
33582           HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33583           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33584           MINT15=MINT(15)
33585           MINT(15)=1
33586           MINT(61)=1
33587           CALL PYWIDT(23,SQM3,WDTP,WDTE)
33588           MINT(15)=MINT15
33589           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33590           DO 240 J=1,3
33591             HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
33592             HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
33593             HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
33594   240     CONTINUE
33595           MINT15=MINT(15)
33596           MINT(15)=1
33597           MINT(61)=1
33598           CALL PYWIDT(23,SQM4,WDTP,WDTE)
33599           MINT(15)=MINT15
33600           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33601           DO 250 J=1,3
33602             HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
33603             HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
33604             HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
33605   250     CONTINUE
33606 C...Loop over flavours; separate left- and right-handed couplings
33607           DO 270 I=MMINA,MMAXA
33608             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
33609             EI=KCHG(IABS(I),1)/3D0
33610             AI=SIGN(1D0,EI)
33611             VI=AI-4D0*EI*XWV
33612             VALI=VI-AI
33613             VARI=VI+AI
33614             FCOI=1D0
33615             IF(IABS(I).LE.10) FCOI=FACA/3D0
33616             DO 260 J=1,3
33617               HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
33618               HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
33619               HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
33620               HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
33621   260       CONTINUE
33622             FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
33623      &      HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
33624      &      HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
33625      &      HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
33626             NCHN=NCHN+1
33627             ISIG(NCHN,1)=I
33628             ISIG(NCHN,2)=-I
33629             ISIG(NCHN,3)=1
33630             SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
33631   270     CONTINUE
33632  
33633         ELSEIF(ISUB.EQ.23) THEN
33634 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
33635           FACZW=COMFAC*0.5D0*(AEM/XW)**2
33636           FACZW=FACZW*WIDS(23,2)
33637           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33638           FACBW=1D0/((SH-SQMW)**2+GMMW**2)
33639           DO 290 I=MMIN1,MMAX1
33640             IA=IABS(I)
33641             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
33642             DO 280 J=MMIN2,MMAX2
33643               JA=IABS(J)
33644               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
33645               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
33646               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33647      &        GOTO 280
33648               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33649               EI=KCHG(IA,1)/3D0
33650               AI=SIGN(1D0,EI+0.1D0)
33651               VI=AI-4D0*EI*XWV
33652               EJ=KCHG(JA,1)/3D0
33653               AJ=SIGN(1D0,EJ+0.1D0)
33654               VJ=AJ-4D0*EJ*XWV
33655               IF(VI+AI.GT.0) THEN
33656                 VISAV=VI
33657                 AISAV=AI
33658                 VI=VJ
33659                 AI=AJ
33660                 VJ=VISAV
33661                 AJ=AISAV
33662               ENDIF
33663               FCKM=1D0
33664               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33665               FCOI=1D0
33666               IF(IA.LE.10) FCOI=FACA/3D0
33667               NCHN=NCHN+1
33668               ISIG(NCHN,1)=I
33669               ISIG(NCHN,2)=J
33670               ISIG(NCHN,3)=1
33671               SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33672      &        (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33673      &        (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33674      &        THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33675      &        SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33676      &        WIDS(24,(5-KCHW)/2)
33677 C***Protect against slightly negative cross sections. (Reason yet to be
33678 C***sorted out. One possibility: addition of width to the W propagator.)
33679               SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33680   280       CONTINUE
33681   290     CONTINUE
33682  
33683         ELSEIF(ISUB.EQ.25) THEN
33684 C...f + fbar -> W+ + W-
33685 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33686           GMMZC=GMMZ
33687           HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33688           HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33689           CALL PYWIDT(24,SQM3,WDTP,WDTE)
33690           GMMW3=SQRT(SQM3)*WDTP(0)
33691           HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33692           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33693           CALL PYWIDT(24,SQM4,WDTP,WDTE)
33694           GMMW4=SQRT(SQM4)*WDTP(0)
33695           HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33696 C...Kinematical functions
33697           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33698           THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33699           GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33700           GT=THUH34+4D0*THUH/TH2
33701           GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33702           GU=THUH34+4D0*THUH/UH2
33703           GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33704 C...Common factors and couplings
33705           FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33706           FACWW=FACWW*WIDS(24,1)
33707           CGG=AEM**2/2D0
33708           CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33709           CZZ=AEM**2/(32D0*XW**2)*HBWZC
33710           CNG=AEM**2/(4D0*XW)
33711           CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33712           CNN=AEM**2/(16D0*XW**2)
33713 C...Coulomb factor for W+W- pair
33714           IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33715             COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33716             COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33717             IF(COULE.LT.100D0*PMAS(24,2)) THEN
33718               COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33719      &        PMAS(24,2)**2)-COULE))
33720             ELSE
33721               COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33722             ENDIF
33723             IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33724               COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33725      &        PMAS(24,2)**2)+COULE))
33726             ELSE
33727               COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33728      &        ABS(COULE)))
33729             ENDIF
33730             IF(MSTP(40).EQ.1) THEN
33731               COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33732      &        MAX(1D-10,2D0*COULP*COULP1))
33733               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33734             ELSEIF(MSTP(40).EQ.2) THEN
33735               COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33736               COULCP=DCMPLX(0D0,DBLE(COULP))
33737               COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33738               COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33739      &        (4D0*COULCP)*LOG(COULCD)
33740               COULCS=DCMPLX(0D0,0D0)
33741               NSTP=100
33742               DO 300 ISTP=1,NSTP
33743                 COULXX=(ISTP-0.5)/NSTP
33744                 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33745      &          (1D0+COULXX/COULCD))
33746   300         CONTINUE
33747               COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33748      &        (COULCS/NSTP)
33749               FACCOU=ABS(COULCR)**2
33750             ELSEIF(MSTP(40).EQ.3) THEN
33751               COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33752      &        COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33753               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33754             ENDIF
33755           ELSEIF(MSTP(40).EQ.4) THEN
33756             FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33757           ELSE
33758             FACCOU=1D0
33759           ENDIF
33760           VINT(95)=FACCOU
33761           FACWW=FACWW*FACCOU
33762 C...Loop over allowed flavours
33763           DO 310 I=MMINA,MMAXA
33764             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33765             EI=KCHG(IABS(I),1)/3D0
33766             AI=SIGN(1D0,EI+0.1D0)
33767             VI=AI-4D0*EI*XWV
33768             FCOI=1D0
33769             IF(IABS(I).LE.10) FCOI=FACA/3D0
33770             IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33771               IF(AI.LT.0D0) THEN
33772                 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33773      &          (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33774               ELSE
33775                 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33776      &          (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33777               ENDIF
33778             ELSE
33779               XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33780               BET=SQRT(1D0-4D0*XMW02/SH)
33781               GAT=1D0/SQRT(1D0-BET**2)
33782               STHE2=1D0-CTH**2
33783               AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33784               AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33785      &        2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33786               AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33787      &        2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33788      &        (1D0-2D0*BET*CTH+BET**2))
33789               PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33790               PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33791               A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33792               A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33793               A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33794               ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33795               ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33796               DSIGWW=ATOT
33797             ENDIF
33798             NCHN=NCHN+1
33799             ISIG(NCHN,1)=I
33800             ISIG(NCHN,2)=-I
33801             ISIG(NCHN,3)=1
33802             SIGH(NCHN)=FACWW*FCOI*DSIGWW
33803   310     CONTINUE
33804  
33805         ELSEIF(ISUB.EQ.30) THEN
33806 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33807           FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33808      &    (-SH*UH)
33809 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33810           HFGG=0D0
33811           HFGZ=0D0
33812           HFZZ=0D0
33813           RADC4=1D0+PYALPS(SQM4)/PARU(1)
33814           DO 320 I=1,MIN(16,MDCY(23,3))
33815             IDC=I+MDCY(23,2)-1
33816             IF(MDME(IDC,1).LT.0) GOTO 320
33817             IMDM=0
33818             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33819      &      IMDM=1
33820             IF(I.LE.8) THEN
33821               EF=KCHG(I,1)/3D0
33822               AF=SIGN(1D0,EF+0.1D0)
33823               VF=AF-4D0*EF*XWV
33824             ELSEIF(I.LE.16) THEN
33825               EF=KCHG(I+2,1)/3D0
33826               AF=SIGN(1D0,EF+0.1D0)
33827               VF=AF-4D0*EF*XWV
33828             ENDIF
33829             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33830             IF(4D0*RM1.LT.1D0) THEN
33831               FCOF=1D0
33832               IF(I.LE.8) FCOF=3D0*RADC4
33833               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33834               IF(IMDM.EQ.1) THEN
33835                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33836                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33837                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33838      &          AF**2*(1D0-4D0*RM1))*BE34
33839               ENDIF
33840             ENDIF
33841   320     CONTINUE
33842 C...Propagators: as simulated in PYOFSH and as desired
33843           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33844           MINT15=MINT(15)
33845           MINT(15)=1
33846           MINT(61)=1
33847           CALL PYWIDT(23,SQM4,WDTP,WDTE)
33848           MINT(15)=MINT15
33849           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33850           HFGG=HFGG*HFAEM*VINT(111)/SQM4
33851           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33852           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33853 C...Loop over flavours; consider full gamma/Z structure
33854           DO 340 I=MMINA,MMAXA
33855             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33856             EI=KCHG(IABS(I),1)/3D0
33857             AI=SIGN(1D0,EI)
33858             VI=AI-4D0*EI*XWV
33859             FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33860      &      (VI**2+AI**2)*HFZZ)/HBW4
33861             DO 330 ISDE=1,2
33862               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33863               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33864               NCHN=NCHN+1
33865               ISIG(NCHN,ISDE)=I
33866               ISIG(NCHN,3-ISDE)=21
33867               ISIG(NCHN,3)=1
33868               SIGH(NCHN)=FACZQ
33869   330       CONTINUE
33870   340     CONTINUE
33871  
33872         ELSEIF(ISUB.EQ.31) THEN
33873 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33874           FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33875      &    (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33876 C...Propagators: as simulated in PYOFSH and as desired
33877           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33878           CALL PYWIDT(24,SQM4,WDTP,WDTE)
33879           GMMWC=SQRT(SQM4)*WDTP(0)
33880           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33881           FACWQ=FACWQ*HBW4C/HBW4
33882           DO 360 I=MMINA,MMAXA
33883             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33884             IA=IABS(I)
33885             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33886             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33887             DO 350 ISDE=1,2
33888               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33889               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33890               NCHN=NCHN+1
33891               ISIG(NCHN,ISDE)=I
33892               ISIG(NCHN,3-ISDE)=21
33893               ISIG(NCHN,3)=1
33894               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33895   350       CONTINUE
33896   360     CONTINUE
33897  
33898         ELSEIF(ISUB.EQ.35) THEN
33899 C...f + gamma -> f + (gamma*/Z0)
33900           IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33901             FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33902             FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33903           ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33904             FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33905             FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33906           ELSE
33907             FZQN=SH2+UH2+2D0*SQM4*TH
33908             FZQDTM=-SH*UH
33909           ENDIF
33910           FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33911 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33912           HFGG=0D0
33913           HFGZ=0D0
33914           HFZZ=0D0
33915           RADC4=1D0+PYALPS(SQM4)/PARU(1)
33916           DO 370 I=1,MIN(16,MDCY(23,3))
33917             IDC=I+MDCY(23,2)-1
33918             IF(MDME(IDC,1).LT.0) GOTO 370
33919             IMDM=0
33920             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33921      &      IMDM=1
33922             IF(I.LE.8) THEN
33923               EF=KCHG(I,1)/3D0
33924               AF=SIGN(1D0,EF+0.1D0)
33925               VF=AF-4D0*EF*XWV
33926             ELSEIF(I.LE.16) THEN
33927               EF=KCHG(I+2,1)/3D0
33928               AF=SIGN(1D0,EF+0.1D0)
33929               VF=AF-4D0*EF*XWV
33930             ENDIF
33931             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33932             IF(4D0*RM1.LT.1D0) THEN
33933               FCOF=1D0
33934               IF(I.LE.8) FCOF=3D0*RADC4
33935               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33936               IF(IMDM.EQ.1) THEN
33937                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33938                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33939                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33940      &          AF**2*(1D0-4D0*RM1))*BE34
33941               ENDIF
33942             ENDIF
33943   370     CONTINUE
33944 C...Propagators: as simulated in PYOFSH and as desired
33945           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33946           MINT15=MINT(15)
33947           MINT(15)=1
33948           MINT(61)=1
33949           CALL PYWIDT(23,SQM4,WDTP,WDTE)
33950           MINT(15)=MINT15
33951           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33952           HFGG=HFGG*HFAEM*VINT(111)/SQM4
33953           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33954           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33955 C...Loop over flavours; consider full gamma/Z structure
33956           DO 390 I=MMINA,MMAXA
33957             IF(I.EQ.0) GOTO 390
33958             EI=KCHG(IABS(I),1)/3D0
33959             AI=SIGN(1D0,EI)
33960             VI=AI-4D0*EI*XWV
33961             FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33962      &      (VI**2+AI**2)*HFZZ)/HBW4
33963             FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33964             DO 380 ISDE=1,2
33965               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33966               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33967               NCHN=NCHN+1
33968               ISIG(NCHN,ISDE)=I
33969               ISIG(NCHN,3-ISDE)=22
33970               ISIG(NCHN,3)=1
33971               SIGH(NCHN)=FACZQ*FZQN/FZQD
33972   380       CONTINUE
33973   390     CONTINUE
33974  
33975         ELSEIF(ISUB.EQ.36) THEN
33976 C...f + gamma -> f' + W+/-
33977           FWQ=COMFAC*AEM**2/(2D0*XW)*
33978      &    (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33979 C...Propagators: as simulated in PYOFSH and as desired
33980           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33981           CALL PYWIDT(24,SQM4,WDTP,WDTE)
33982           GMMWC=SQRT(SQM4)*WDTP(0)
33983           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33984           FWQ=FWQ*HBW4C/HBW4
33985           DO 410 I=MMINA,MMAXA
33986             IF(I.EQ.0) GOTO 410
33987             IA=IABS(I)
33988             EIA=ABS(KCHG(IABS(I),1)/3D0)
33989             FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33990             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33991             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33992             DO 400 ISDE=1,2
33993               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33994               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33995               NCHN=NCHN+1
33996               ISIG(NCHN,ISDE)=I
33997               ISIG(NCHN,3-ISDE)=22
33998               ISIG(NCHN,3)=1
33999               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
34000   400       CONTINUE
34001   410     CONTINUE
34002         ENDIF
34003  
34004       ELSEIF(ISUB.LE.100) THEN
34005         IF(ISUB.EQ.69) THEN
34006 C...gamma + gamma -> W+ + W-
34007           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34008           FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
34009           FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
34010      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
34011           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
34012           NCHN=NCHN+1
34013           ISIG(NCHN,1)=22
34014           ISIG(NCHN,2)=22
34015           ISIG(NCHN,3)=1
34016           SIGH(NCHN)=FACWW
34017   420     CONTINUE
34018  
34019         ELSEIF(ISUB.EQ.70) THEN
34020 C...gamma + W+/- -> Z0 + W+/-
34021           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34022           FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
34023           FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
34024      &    (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
34025      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
34026           DO 440 KCHW=1,-1,-2
34027             DO 430 ISDE=1,2
34028               IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
34029               NCHN=NCHN+1
34030               ISIG(NCHN,ISDE)=22
34031               ISIG(NCHN,3-ISDE)=24*KCHW
34032               ISIG(NCHN,3)=1
34033               SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
34034   430       CONTINUE
34035   440     CONTINUE
34036         ENDIF
34037       ENDIF
34038  
34039       RETURN
34040       END
34041  
34042 C*********************************************************************
34043  
34044 C...PYSGHG
34045 C...Subprocess cross sections for Higgs processes,
34046 C...except Higgs pairs in PYSGSU, but including WW scattering.
34047 C...Auxiliary to PYSIGH.
34048  
34049       SUBROUTINE PYSGHG(NCHN,SIGS)
34050  
34051 C...Double precision and integer declarations
34052       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34053       IMPLICIT INTEGER(I-N)
34054       INTEGER PYK,PYCHGE,PYCOMP
34055 C...Parameter statement to help give large particle numbers.
34056       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34057      &KEXCIT=4000000,KDIMEN=5000000)
34058 C...Commonblocks
34059       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34060       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34061       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34062       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34063       COMMON/PYINT1/MINT(400),VINT(400)
34064       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34065       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34066       COMMON/PYINT4/MWID(500),WIDS(500,5)
34067       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
34068       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34069       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34070      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34071      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34072      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34073       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34074      &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
34075 C...Local arrays and complex variables
34076       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34077       COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
34078       COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
34079  
34080 C...Convert H or A process into equivalent h one
34081       IHIGG=1
34082       KFHIGG=25
34083       IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
34084          KFHIGG=KFPR(ISUB,1)
34085       END IF
34086       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
34087      &ISUB.LE.190)) THEN
34088         IHIGG=2
34089         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
34090         KFHIGG=33+IHIGG
34091         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
34092         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
34093         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
34094         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
34095         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
34096         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
34097         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
34098         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
34099         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
34100         IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
34101         IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
34102         IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
34103       ENDIF
34104       SQMH=PMAS(KFHIGG,1)**2
34105       GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
34106  
34107 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34108       IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
34109      &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
34110 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
34111         IF(MSTP(46).LE.4) THEN
34112           HDTLH=LOG(PMAS(25,1)/PARP(44))
34113           HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
34114           HDTNR=-1D0/18D0+HDTLH/6D0
34115         ELSE
34116           HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
34117           HDTLQ=LOG(PARP(45)/PARP(44))
34118           HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
34119           HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
34120         ENDIF
34121  
34122 C...Calculate lowest and next-to-lowest order partial wave amplitudes
34123         HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
34124         A00L=DBLE(HDTV*SH)
34125         A20L=-0.5D0*A00L
34126         A11L=A00L/6D0
34127         HDTLS=LOG(SH/PARP(44)**2)
34128         A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34129      &  CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
34130      &  (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
34131         A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34132      &  CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
34133      &  (20D0/9D0)*HDTLS),DBLE(PARU(1)))
34134         A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
34135      &  CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
34136  
34137 C...Unitarize partial wave amplitudes with Pade or K-matrix method
34138         IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
34139           A00U=A00L/(1D0-A004/A00L)
34140           A20U=A20L/(1D0-A204/A20L)
34141           A11U=A11L/(1D0-A114/A11L)
34142         ELSE
34143           A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
34144           A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
34145           A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
34146         ENDIF
34147       ENDIF
34148  
34149 C...Differential cross section expressions.
34150  
34151       IF(ISUB.LE.60) THEN
34152         IF(ISUB.EQ.3) THEN
34153 C...f + fbar -> h0 (or H0, or A0)
34154           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34155           HS=SHR*WDTP(0)
34156           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34157           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34158      &    FACBW=0D0
34159           HP=AEM/(8D0*XW)*SH/SQMW*SH
34160           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34161           DO 100 I=MMINA,MMAXA
34162             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
34163             IA=IABS(I)
34164             RMQ=PYMRUN(IA,SH)**2/SH
34165             HI=HP*RMQ
34166             IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
34167             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34168               IKFI=1
34169               IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34170               IF(IA.GT.10) IKFI=3
34171               HI=HI*PARU(150+10*IHIGG+IKFI)**2
34172               IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34173                 HI=HI/(1D0+RMSS(41))**2
34174                 IF(IHIGG.NE.3) THEN
34175                   HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34176      &            PARU(151+10*IHIGG))**2
34177                 ENDIF
34178               ENDIF
34179             ENDIF
34180             NCHN=NCHN+1
34181             ISIG(NCHN,1)=I
34182             ISIG(NCHN,2)=-I
34183             ISIG(NCHN,3)=1
34184             SIGH(NCHN)=HI*FACBW*HF
34185   100     CONTINUE
34186  
34187         ELSEIF(ISUB.EQ.5) THEN
34188 C...Z0 + Z0 -> h0
34189           CALL PYWIDT(25,SH,WDTP,WDTE)
34190           HS=SHR*WDTP(0)
34191           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34192           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34193           HP=AEM/(8D0*XW)*SH/SQMW*SH
34194           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34195           HI=HP/4D0
34196           FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
34197           DO 120 I=MMIN1,MMAX1
34198             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
34199             DO 110 J=MMIN2,MMAX2
34200               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
34201               EI=KCHG(IABS(I),1)/3D0
34202               AI=SIGN(1D0,EI)
34203               VI=AI-4D0*EI*XWV
34204               EJ=KCHG(IABS(J),1)/3D0
34205               AJ=SIGN(1D0,EJ)
34206               VJ=AJ-4D0*EJ*XWV
34207               NCHN=NCHN+1
34208               ISIG(NCHN,1)=I
34209               ISIG(NCHN,2)=J
34210               ISIG(NCHN,3)=1
34211               SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
34212   110       CONTINUE
34213   120     CONTINUE
34214  
34215         ELSEIF(ISUB.EQ.8) THEN
34216 C...W+ + W- -> h0
34217           CALL PYWIDT(25,SH,WDTP,WDTE)
34218           HS=SHR*WDTP(0)
34219           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34220           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34221           HP=AEM/(8D0*XW)*SH/SQMW*SH
34222           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34223           HI=HP/2D0
34224           FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
34225           DO 140 I=MMIN1,MMAX1
34226             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
34227             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34228             DO 130 J=MMIN2,MMAX2
34229               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
34230               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34231               IF(EI*EJ.GT.0D0) GOTO 130
34232               NCHN=NCHN+1
34233               ISIG(NCHN,1)=I
34234               ISIG(NCHN,2)=J
34235               ISIG(NCHN,3)=1
34236               SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
34237   130       CONTINUE
34238   140     CONTINUE
34239  
34240         ELSEIF(ISUB.EQ.24) THEN
34241 C...f + fbar -> Z0 + h0 (or H0, or A0)
34242 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
34243           HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
34244           CALL PYWIDT(23,SQM3,WDTP,WDTE)
34245           GMMZ3=SQRT(SQM3)*WDTP(0)
34246           HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
34247           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34248           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34249           GMMH4=SQRT(SQM4)*WDTP(0)
34250           HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34251           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34252           FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
34253      &    (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
34254           FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
34255           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
34256      &    PARU(154+10*IHIGG)**2
34257           DO 150 I=MMINA,MMAXA
34258             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
34259             EI=KCHG(IABS(I),1)/3D0
34260             AI=SIGN(1D0,EI)
34261             VI=AI-4D0*EI*XWV
34262             FCOI=1D0
34263             IF(IABS(I).LE.10) FCOI=FACA/3D0
34264             NCHN=NCHN+1
34265             ISIG(NCHN,1)=I
34266             ISIG(NCHN,2)=-I
34267             ISIG(NCHN,3)=1
34268             SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
34269   150     CONTINUE
34270  
34271         ELSEIF(ISUB.EQ.26) THEN
34272 C...f + fbar' -> W+/- + h0 (or H0, or A0)
34273 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
34274           HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
34275           CALL PYWIDT(24,SQM3,WDTP,WDTE)
34276           GMMW3=SQRT(SQM3)*WDTP(0)
34277           HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
34278           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34279           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34280           GMMH4=SQRT(SQM4)*WDTP(0)
34281           HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34282           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34283           FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
34284      &    ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
34285           FACHW=FACHW*WIDS(KFHIGG,2)
34286           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
34287      &    PARU(155+10*IHIGG)**2
34288           DO 170 I=MMIN1,MMAX1
34289             IA=IABS(I)
34290             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
34291             DO 160 J=MMIN2,MMAX2
34292               JA=IABS(J)
34293               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
34294               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
34295               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34296      &        GOTO 160
34297               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34298               FCKM=1D0
34299               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34300               FCOI=1D0
34301               IF(IA.LE.10) FCOI=FACA/3D0
34302               NCHN=NCHN+1
34303               ISIG(NCHN,1)=I
34304               ISIG(NCHN,2)=J
34305               ISIG(NCHN,3)=1
34306               SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
34307   160       CONTINUE
34308   170     CONTINUE
34309  
34310         ELSEIF(ISUB.EQ.32) THEN
34311 C...f + g -> f + h0 (q + g -> q + h0 only)
34312           FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
34313 C...H propagator: as simulated in PYOFSH and as desired
34314           SQMHC=PMAS(25,1)**2
34315           GMMHC=PMAS(25,1)*PMAS(25,2)
34316           HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34317           CALL PYWIDT(25,SQM4,WDTP,WDTE)
34318           GMMHCC=SQRT(SQM4)*WDTP(0)
34319           HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34320           FHCQ=FHCQ*HBW4C/HBW4
34321           DO 190 I=MMINA,MMAXA
34322             IA=IABS(I)
34323             IF(IA.NE.5) GOTO 190
34324             SQML=PYMRUN(IA,SH)**2
34325             SQMQ=PMAS(IA,1)**2
34326             FACHCQ=FHCQ*SQML/SQMW*
34327      &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34328      &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
34329      &      (SQM4-SQMQ-SH)/SH)
34330             DO 180 ISDE=1,2
34331               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
34332               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
34333               NCHN=NCHN+1
34334               ISIG(NCHN,ISDE)=I
34335               ISIG(NCHN,3-ISDE)=21
34336               ISIG(NCHN,3)=1
34337               SIGH(NCHN)=FACHCQ*WIDS(25,2)
34338   180       CONTINUE
34339   190     CONTINUE
34340         ENDIF
34341  
34342       ELSEIF(ISUB.LE.80) THEN
34343         IF(ISUB.EQ.71) THEN
34344 C...Z0 + Z0 -> Z0 + Z0
34345           IF(SH.LE.4.01D0*SQMZ) GOTO 220
34346  
34347           IF(MSTP(46).LE.2) THEN
34348 C...Exact scattering ME:s for on-mass-shell gauge bosons
34349             BE2=1D0-4D0*SQMZ/SH
34350             TH=-0.5D0*SH*BE2*(1D0-CTH)
34351             UH=-0.5D0*SH*BE2*(1D0+CTH)
34352             IF(MAX(TH,UH).GT.-1D0) GOTO 220
34353             SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
34354             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34355             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34356             THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
34357             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34358             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34359             UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
34360             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34361             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34362             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34363      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34364             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34365             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
34366      &      (ASHIM+ATHIM+AUHIM)**2)
34367             IF(MSTP(46).EQ.2) FACZZ=0D0
34368  
34369           ELSE
34370 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34371             FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34372      &      ABS(A00U+2D0*A20U)**2
34373           ENDIF
34374           FACZZ=FACZZ*WIDS(23,1)
34375  
34376           DO 210 I=MMIN1,MMAX1
34377             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
34378             EI=KCHG(IABS(I),1)/3D0
34379             AI=SIGN(1D0,EI)
34380             VI=AI-4D0*EI*XWV
34381             AVI=AI**2+VI**2
34382             DO 200 J=MMIN2,MMAX2
34383               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
34384               EJ=KCHG(IABS(J),1)/3D0
34385               AJ=SIGN(1D0,EJ)
34386               VJ=AJ-4D0*EJ*XWV
34387               AVJ=AJ**2+VJ**2
34388               NCHN=NCHN+1
34389               ISIG(NCHN,1)=I
34390               ISIG(NCHN,2)=J
34391               ISIG(NCHN,3)=1
34392               SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
34393   200       CONTINUE
34394   210     CONTINUE
34395   220     CONTINUE
34396  
34397         ELSEIF(ISUB.EQ.72) THEN
34398 C...Z0 + Z0 -> W+ + W-
34399           IF(SH.LE.4.01D0*SQMZ) GOTO 250
34400  
34401           IF(MSTP(46).LE.2) THEN
34402 C...Exact scattering ME:s for on-mass-shell gauge bosons
34403             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34404             CTH2=CTH**2
34405             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34406             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34407             IF(MAX(TH,UH).GT.-1D0) GOTO 250
34408             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34409      &      (1D0-2D0*SQMZ/SH)
34410             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34411             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34412             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34413      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34414      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34415      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34416      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34417             ATWIM=0D0
34418             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34419      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34420      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34421      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34422      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34423             AUWIM=0D0
34424             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34425             A4IM=0D0
34426             FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34427      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34428             IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
34429             IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34430      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
34431             IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
34432      &      (ATWIM+AUWIM+A4IM)**2)
34433  
34434           ELSE
34435 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34436             FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34437      &      ABS(A00U-A20U)**2
34438           ENDIF
34439           FACWW=FACWW*WIDS(24,1)
34440  
34441           DO 240 I=MMIN1,MMAX1
34442             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
34443             EI=KCHG(IABS(I),1)/3D0
34444             AI=SIGN(1D0,EI)
34445             VI=AI-4D0*EI*XWV
34446             AVI=AI**2+VI**2
34447             DO 230 J=MMIN2,MMAX2
34448               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
34449               EJ=KCHG(IABS(J),1)/3D0
34450               AJ=SIGN(1D0,EJ)
34451               VJ=AJ-4D0*EJ*XWV
34452               AVJ=AJ**2+VJ**2
34453               NCHN=NCHN+1
34454               ISIG(NCHN,1)=I
34455               ISIG(NCHN,2)=J
34456               ISIG(NCHN,3)=1
34457               SIGH(NCHN)=FACWW*AVI*AVJ
34458   230       CONTINUE
34459   240     CONTINUE
34460   250     CONTINUE
34461  
34462         ELSEIF(ISUB.EQ.73) THEN
34463 C...Z0 + W+/- -> Z0 + W+/-
34464           IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
34465  
34466           IF(MSTP(46).LE.2) THEN
34467 C...Exact scattering ME:s for on-mass-shell gauge bosons
34468             BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
34469             EP1=1D0-(SQMZ-SQMW)/SH
34470             EP2=1D0+(SQMZ-SQMW)/SH
34471             TH=-0.5D0*SH*BE2*(1D0-CTH)
34472             UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
34473             IF(MAX(TH,UH).GT.-1D0) GOTO 280
34474             THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
34475             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34476             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34477             ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
34478      &      1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
34479      &      2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
34480      &      1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
34481             ASWIM=0D0
34482             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
34483      &      (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
34484      &      (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
34485      &      BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
34486      &      (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
34487      &      1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
34488      &      (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
34489      &      (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
34490      &      (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
34491      &      (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
34492      &      ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
34493      &      (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
34494             AUWIM=0D0
34495             A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
34496      &      2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
34497             A4IM=0D0
34498             FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
34499      &      (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
34500             IF(MSTP(46).LE.0) FACZW=0D0
34501             IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
34502      &      (ATHIM+ASWIM+AUWIM+A4IM)**2)
34503             IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
34504      &      (ASWIM+AUWIM+A4IM)**2)
34505  
34506           ELSE
34507 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34508             FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
34509      &      ABS(A20U+3D0*A11U*DBLE(CTH))**2
34510           ENDIF
34511           FACZW=FACZW*WIDS(23,2)
34512  
34513           DO 270 I=MMIN1,MMAX1
34514             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
34515             EI=KCHG(IABS(I),1)/3D0
34516             AI=SIGN(1D0,EI)
34517             VI=AI-4D0*EI*XWV
34518             AVI=AI**2+VI**2
34519             KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
34520             DO 260 J=MMIN2,MMAX2
34521               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
34522               EJ=KCHG(IABS(J),1)/3D0
34523               AJ=SIGN(1D0,EJ)
34524               VJ=AI-4D0*EJ*XWV
34525               AVJ=AJ**2+VJ**2
34526               KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
34527               NCHN=NCHN+1
34528               ISIG(NCHN,1)=I
34529               ISIG(NCHN,2)=J
34530               ISIG(NCHN,3)=1
34531               SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
34532               NCHN=NCHN+1
34533               ISIG(NCHN,1)=I
34534               ISIG(NCHN,2)=J
34535               ISIG(NCHN,3)=2
34536               SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
34537   260       CONTINUE
34538   270     CONTINUE
34539   280     CONTINUE
34540  
34541         ELSEIF(ISUB.EQ.75) THEN
34542 C...W+ + W- -> gamma + gamma
34543  
34544         ELSEIF(ISUB.EQ.76) THEN
34545 C...W+ + W- -> Z0 + Z0
34546           IF(SH.LE.4.01D0*SQMZ) GOTO 310
34547  
34548           IF(MSTP(46).LE.2) THEN
34549 C...Exact scattering ME:s for on-mass-shell gauge bosons
34550             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34551             CTH2=CTH**2
34552             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34553             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34554             IF(MAX(TH,UH).GT.-1D0) GOTO 310
34555             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34556      &      (1D0-2D0*SQMZ/SH)
34557             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34558             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34559             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34560      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34561      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34562      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34563      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34564             ATWIM=0D0
34565             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34566      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34567      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34568      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34569      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34570             AUWIM=0D0
34571             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34572             A4IM=0D0
34573             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34574      &      (SH/SQMW)**2*SH2
34575             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34576             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34577      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
34578             IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
34579      &      (ATWIM+AUWIM+A4IM)**2)
34580  
34581           ELSE
34582 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34583             FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34584      &      ABS(A00U-A20U)**2
34585           ENDIF
34586           FACZZ=FACZZ*WIDS(23,1)
34587  
34588           DO 300 I=MMIN1,MMAX1
34589             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
34590             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34591             DO 290 J=MMIN2,MMAX2
34592               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
34593               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34594               IF(EI*EJ.GT.0D0) GOTO 290
34595               NCHN=NCHN+1
34596               ISIG(NCHN,1)=I
34597               ISIG(NCHN,2)=J
34598               ISIG(NCHN,3)=1
34599               SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
34600   290       CONTINUE
34601   300     CONTINUE
34602   310     CONTINUE
34603  
34604         ELSEIF(ISUB.EQ.77) THEN
34605 C...W+/- + W+/- -> W+/- + W+/-
34606           IF(SH.LE.4.01D0*SQMW) GOTO 340
34607  
34608           IF(MSTP(46).LE.2) THEN
34609 C...Exact scattering ME:s for on-mass-shell gauge bosons
34610             BE2=1D0-4D0*SQMW/SH
34611             BE4=BE2**2
34612             CTH2=CTH**2
34613             CTH3=CTH**3
34614             TH=-0.5D0*SH*BE2*(1D0-CTH)
34615             UH=-0.5D0*SH*BE2*(1D0+CTH)
34616             IF(MAX(TH,UH).GT.-1D0) GOTO 340
34617             SHANG=(1D0+BE2)**2
34618             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34619             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34620             THANG=(BE2-CTH)**2
34621             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34622             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34623             UHANG=(BE2+CTH)**2
34624             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34625             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34626             SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
34627             ASGRE=XW*SGZANG
34628             ASGIM=0D0
34629             ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
34630             ASZIM=0D0
34631             TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
34632      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
34633             ATGRE=0.5D0*XW*SH/TH*TGZANG
34634             ATGIM=0D0
34635             ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
34636             ATZIM=0D0
34637             UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
34638      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
34639             AUGRE=0.5D0*XW*SH/UH*UGZANG
34640             AUGIM=0D0
34641             AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
34642             AUZIM=0D0
34643             A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
34644             A4AIM=0D0
34645             A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
34646             A4SIM=0D0
34647             FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34648      &      (SH/SQMW)**2*SH2
34649             IF(MSTP(46).LE.0) THEN
34650               AWWARE=ASHRE
34651               AWWAIM=ASHIM
34652               AWWSRE=0D0
34653               AWWSIM=0D0
34654             ELSEIF(MSTP(46).EQ.1) THEN
34655               AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34656               AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34657               AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34658               AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34659             ELSE
34660               AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34661               AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34662               AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34663               AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34664             ENDIF
34665             AWWA2=AWWARE**2+AWWAIM**2
34666             AWWS2=AWWSRE**2+AWWSIM**2
34667  
34668           ELSE
34669 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34670             FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34671      &      ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34672             FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34673           ENDIF
34674  
34675           DO 330 I=MMIN1,MMAX1
34676             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34677             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34678             DO 320 J=MMIN2,MMAX2
34679               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34680               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34681               IF(EI*EJ.LT.0D0) THEN
34682 C...W+W-
34683                 IF(MSTP(45).EQ.1) GOTO 320
34684                 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34685                 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34686               ELSE
34687 C...W+W+/W-W-
34688                 IF(MSTP(45).EQ.2) GOTO 320
34689                 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34690                 IF(MSTP(46).GE.3) FACWW=FWWS
34691                 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34692                 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34693               ENDIF
34694               NCHN=NCHN+1
34695               ISIG(NCHN,1)=I
34696               ISIG(NCHN,2)=J
34697               ISIG(NCHN,3)=1
34698               SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34699               IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34700   320       CONTINUE
34701   330     CONTINUE
34702   340     CONTINUE
34703         ENDIF
34704  
34705       ELSEIF(ISUB.LE.120) THEN
34706         IF(ISUB.EQ.102) THEN
34707 C...g + g -> h0 (or H0, or A0)
34708           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34709           HS=SHR*WDTP(0)
34710           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34711           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34712           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34713      &    FACBW=0D0
34714 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34715           IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34716             WDTP13=0D0
34717             DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34718               IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34719      &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34720  345        CONTINUE
34721             IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34722      &          '(PYSGHG:) did not find Higgs -> g g channel')  
34723             HI=SHR*WDTP13/32D0
34724           ELSE
34725             HI=SHR*WDTP(13)/32D0 
34726           ENDIF
34727           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34728           NCHN=NCHN+1
34729           ISIG(NCHN,1)=21
34730           ISIG(NCHN,2)=21
34731           ISIG(NCHN,3)=1
34732           SIGH(NCHN)=HI*FACBW*HF
34733   350     CONTINUE
34734  
34735         ELSEIF(ISUB.EQ.103) THEN
34736 C...gamma + gamma -> h0 (or H0, or A0)
34737           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34738           HS=SHR*WDTP(0)
34739           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34740           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34741           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34742      &    FACBW=0D0
34743 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34744           IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34745             WDTP14=0D0
34746             DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34747               IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34748      &            KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34749  355        CONTINUE
34750             IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34751      &          '(PYSGHG:) did not find Higgs -> gamma gamma channel') 
34752             HI=SHR*WDTP14*2D0
34753           ELSE
34754             HI=SHR*WDTP(14)*2D0
34755           ENDIF
34756           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34757           NCHN=NCHN+1
34758           ISIG(NCHN,1)=22
34759           ISIG(NCHN,2)=22
34760           ISIG(NCHN,3)=1
34761           SIGH(NCHN)=HI*FACBW*HF
34762   360     CONTINUE
34763  
34764         ELSEIF(ISUB.EQ.110) THEN
34765 C...f + fbar -> gamma + h0
34766           THUH=MAX(TH*UH,SH*CKIN(3)**2)
34767           FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34768           FACHG=FACHG*WIDS(KFHIGG,2)
34769 C...Calculate loop contributions for intermediate gamma* and Z0
34770           CIGTOT=DCMPLX(0D0,0D0)
34771           CIZTOT=DCMPLX(0D0,0D0)
34772           JMAX=3*MSTP(1)+1
34773           DO 370 J=1,JMAX
34774             IF(J.LE.2*MSTP(1)) THEN
34775               FNC=1D0
34776               EJ=KCHG(J,1)/3D0
34777               AJ=SIGN(1D0,EJ+0.1D0)
34778               VJ=AJ-4D0*EJ*XWV
34779               BALP=SQM4/(2D0*PMAS(J,1))**2
34780               BBET=SH/(2D0*PMAS(J,1))**2
34781             ELSEIF(J.LE.3*MSTP(1)) THEN
34782               FNC=3D0
34783               JL=2*(J-2*MSTP(1))-1
34784               EJ=KCHG(10+JL,1)/3D0
34785               AJ=SIGN(1D0,EJ+0.1D0)
34786               VJ=AJ-4D0*EJ*XWV
34787               BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34788               BBET=SH/(2D0*PMAS(10+JL,1))**2
34789             ELSE
34790               BALP=SQM4/(2D0*PMAS(24,1))**2
34791               BBET=SH/(2D0*PMAS(24,1))**2
34792             ENDIF
34793             BABI=1D0/(BALP-BBET)
34794             IF(BALP.LT.1D0) THEN
34795               F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34796               F1ALP=F0ALP**2
34797             ELSE
34798               F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34799      &        -DBLE(0.5D0*PARU(1)))
34800               F1ALP=-F0ALP**2
34801             ENDIF
34802             F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34803             IF(BBET.LT.1D0) THEN
34804               F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34805               F1BET=F0BET**2
34806             ELSE
34807               F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34808      &        -DBLE(0.5D0*PARU(1)))
34809               F1BET=-F0BET**2
34810             ENDIF
34811             F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34812             IF(J.LE.3*MSTP(1)) THEN
34813               FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34814      &        BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34815               CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34816               CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34817             ELSE
34818               TXW=XW/XW1
34819               CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34820      &        (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34821      &        DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34822               CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34823      &        (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34824      &        DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34825      &        (F1BET-F1ALP))
34826             ENDIF
34827   370     CONTINUE
34828           CIGTOT=CIGTOT/DBLE(SH)
34829           CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34830 C...Loop over initial flavours
34831           DO 380 I=MMINA,MMAXA
34832             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34833             EI=KCHG(IABS(I),1)/3D0
34834             AI=SIGN(1D0,EI)
34835             VI=AI-4D0*EI*XWV
34836             FCOI=1D0
34837             IF(IABS(I).LE.10) FCOI=FACA/3D0
34838             NCHN=NCHN+1
34839             ISIG(NCHN,1)=I
34840             ISIG(NCHN,2)=-I
34841             ISIG(NCHN,3)=1
34842             SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34843      &      CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34844   380     CONTINUE
34845  
34846         ELSEIF(ISUB.EQ.111) THEN
34847 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34848           IF(MSTP(38).NE.0) THEN
34849 C...Simple case: only do gg <-> h exactly.
34850           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34851 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34852           IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34853             WDTP13=0D0
34854             DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34855               IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34856      &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34857  385        CONTINUE
34858             IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34859      &          '(PYSGHG:) did not find Higgs -> g g channel')  
34860             FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34861      &          (TH**2+UH**2)/(SH*SQM4)
34862           ELSE
34863             FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34864      &          (TH**2+UH**2)/(SH*SQM4)
34865           ENDIF
34866 C...Propagators: as simulated in PYOFSH and as desired
34867           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34868           GMMHC=SQRT(SQM4)*WDTP(0)
34869           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34870      &    ((SQM4-SQMH)**2+GMMHC**2)
34871           FACGH=FACGH*HBW4C/HBW4
34872           ELSE
34873 C...Messy case: do full loop integrals
34874           A5STUR=0D0
34875           A5STUI=0D0
34876           DO 390 I=1,2*MSTP(1)
34877             SQMQ=PMAS(I,1)**2
34878             EPSS=4D0*SQMQ/SH
34879             EPSH=4D0*SQMQ/SQMH
34880             CALL PYWAUX(1,EPSS,W1SR,W1SI)
34881             CALL PYWAUX(1,EPSH,W1HR,W1HI)
34882             CALL PYWAUX(2,EPSS,W2SR,W2SI)
34883             CALL PYWAUX(2,EPSH,W2HR,W2HI)
34884             A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34885      &      (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34886             A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34887      &      (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34888   390     CONTINUE
34889           FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34890      &    SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34891           FACGH=FACGH*WIDS(25,2)
34892           ENDIF
34893           DO 400 I=MMINA,MMAXA
34894             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34895      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34896             NCHN=NCHN+1
34897             ISIG(NCHN,1)=I
34898             ISIG(NCHN,2)=-I
34899             ISIG(NCHN,3)=1
34900             SIGH(NCHN)=FACGH
34901   400     CONTINUE
34902  
34903         ELSEIF(ISUB.EQ.112) THEN
34904 C...f + g -> f + h0 (q + g -> q + h0 only)
34905           IF(MSTP(38).NE.0) THEN
34906 C...Simple case: only do gg <-> h exactly.
34907           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34908 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34909           IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34910             WDTP13=0D0
34911             DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34912               IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34913      &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34914  405        CONTINUE
34915             IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34916      &          '(PYSGHG:) did not find Higgs -> g g channel')  
34917             FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34918      &          (SH**2+UH**2)/(-TH*SQM4)
34919           ELSE
34920             FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34921      &          (SH**2+UH**2)/(-TH*SQM4)
34922           ENDIF
34923 C...Propagators: as simulated in PYOFSH and as desired
34924           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34925           GMMHC=SQRT(SQM4)*WDTP(0)
34926           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34927      &    ((SQM4-SQMH)**2+GMMHC**2)
34928           FACQH=FACQH*HBW4C/HBW4
34929           ELSE
34930 C...Messy case: do full loop integrals
34931           A5TSUR=0D0
34932           A5TSUI=0D0
34933           DO 410 I=1,2*MSTP(1)
34934             SQMQ=PMAS(I,1)**2
34935             EPST=4D0*SQMQ/TH
34936             EPSH=4D0*SQMQ/SQMH
34937             CALL PYWAUX(1,EPST,W1TR,W1TI)
34938             CALL PYWAUX(1,EPSH,W1HR,W1HI)
34939             CALL PYWAUX(2,EPST,W2TR,W2TI)
34940             CALL PYWAUX(2,EPSH,W2HR,W2HI)
34941             A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34942      &      (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34943             A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34944      &      (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34945   410     CONTINUE
34946           FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34947      &    SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34948           FACQH=FACQH*WIDS(25,2)
34949           ENDIF
34950           DO 430 I=MMINA,MMAXA
34951             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34952             DO 420 ISDE=1,2
34953               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34954               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34955               NCHN=NCHN+1
34956               ISIG(NCHN,ISDE)=I
34957               ISIG(NCHN,3-ISDE)=21
34958               ISIG(NCHN,3)=1
34959               SIGH(NCHN)=FACQH
34960   420       CONTINUE
34961   430     CONTINUE
34962  
34963         ELSEIF(ISUB.EQ.113) THEN
34964 C...g + g -> g + h0
34965           IF(MSTP(38).NE.0) THEN
34966 C...Simple case: only do gg <-> h exactly.
34967           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34968 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34969           IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34970             WDTP13=0D0
34971             DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34972               IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34973      &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34974  435        CONTINUE
34975             IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34976      &          '(PYSGHG:) did not find Higgs -> g g channel')  
34977             FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34978      &          (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34979           ELSE
34980             FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34981      &          (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34982           ENDIF
34983 C...Propagators: as simulated in PYOFSH and as desired
34984           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34985           GMMHC=SQRT(SQM4)*WDTP(0)
34986           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34987      &    ((SQM4-SQMH)**2+GMMHC**2)
34988           FACGH=FACGH*HBW4C/HBW4
34989           ELSE
34990 C...Messy case: do full loop integrals
34991           A2STUR=0D0
34992           A2STUI=0D0
34993           A2USTR=0D0
34994           A2USTI=0D0
34995           A2TUSR=0D0
34996           A2TUSI=0D0
34997           A4STUR=0D0
34998           A4STUI=0D0
34999           DO 440 I=1,2*MSTP(1)
35000             SQMQ=PMAS(I,1)**2
35001             EPSS=4D0*SQMQ/SH
35002             EPST=4D0*SQMQ/TH
35003             EPSU=4D0*SQMQ/UH
35004             EPSH=4D0*SQMQ/SQMH
35005             IF(EPSH.LT.1D-6) GOTO 440
35006             CALL PYWAUX(1,EPSS,W1SR,W1SI)
35007             CALL PYWAUX(1,EPST,W1TR,W1TI)
35008             CALL PYWAUX(1,EPSU,W1UR,W1UI)
35009             CALL PYWAUX(1,EPSH,W1HR,W1HI)
35010             CALL PYWAUX(2,EPSS,W2SR,W2SI)
35011             CALL PYWAUX(2,EPST,W2TR,W2TI)
35012             CALL PYWAUX(2,EPSU,W2UR,W2UI)
35013             CALL PYWAUX(2,EPSH,W2HR,W2HI)
35014             CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
35015             CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
35016             CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
35017             CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
35018             CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
35019             CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
35020             CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
35021             CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
35022             CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
35023             CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
35024             CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
35025             CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
35026             W3STUR=YHSTUR-Y3STUR-Y3UTSR
35027             W3STUI=YHSTUI-Y3STUI-Y3UTSI
35028             W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
35029             W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
35030             W3TSUR=YHTSUR-Y3TSUR-Y3USTR
35031             W3TSUI=YHTSUI-Y3TSUI-Y3USTI
35032             W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
35033             W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
35034             W3USTR=YHUSTR-Y3USTR-Y3TSUR
35035             W3USTI=YHUSTI-Y3USTI-Y3TSUI
35036             W3UTSR=YHUTSR-Y3UTSR-Y3STUR
35037             W3UTSI=YHUTSI-Y3UTSI-Y3STUI
35038             B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
35039      &      (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
35040      &      (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
35041      &      (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
35042      &      (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
35043             B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
35044      &      (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
35045      &      W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
35046      &      (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
35047      &      (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
35048             B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
35049      &      (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
35050      &      (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
35051      &      (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
35052      &      (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
35053             B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
35054      &      (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
35055      &      W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
35056      &      (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
35057      &      (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
35058             B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
35059      &      (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
35060      &      (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
35061      &      (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
35062      &      (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
35063             B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
35064      &      (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
35065      &      W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
35066      &      (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
35067      &      (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
35068             B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
35069      &      (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
35070      &      (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
35071      &      (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
35072      &      (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
35073             B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
35074      &      (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
35075      &      W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
35076      &      (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
35077      &      (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
35078             B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
35079      &      (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
35080      &      (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
35081      &      (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
35082      &      (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
35083             B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
35084      &      (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
35085      &      W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
35086      &      (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
35087      &      (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
35088             B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
35089      &      (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
35090      &      (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
35091      &      (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
35092      &      (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
35093             B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
35094      &      (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
35095      &      W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
35096      &      (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
35097      &      (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
35098             B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35099      &      (W2SR-W2HR+W3STUR))
35100             B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
35101             B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35102      &      (W2TR-W2HR+W3TUSR))
35103             B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
35104             B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35105      &      (W2UR-W2HR+W3USTR))
35106             B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
35107             A2STUR=A2STUR+B2STUR+B2SUTR
35108             A2STUI=A2STUI+B2STUI+B2SUTI
35109             A2USTR=A2USTR+B2USTR+B2UTSR
35110             A2USTI=A2USTI+B2USTI+B2UTSI
35111             A2TUSR=A2TUSR+B2TUSR+B2TSUR
35112             A2TUSI=A2TUSI+B2TUSI+B2TSUI
35113             A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
35114             A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
35115   440     CONTINUE
35116           FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
35117      &    SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
35118      &    A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
35119           FACGH=FACGH*WIDS(25,2)
35120           ENDIF
35121           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
35122           NCHN=NCHN+1
35123           ISIG(NCHN,1)=21
35124           ISIG(NCHN,2)=21
35125           ISIG(NCHN,3)=1
35126           SIGH(NCHN)=FACGH
35127   450     CONTINUE
35128         ENDIF
35129  
35130       ELSEIF(ISUB.LE.170) THEN
35131         IF(ISUB.EQ.121) THEN
35132 C...g + g -> Q + Qbar + h0
35133           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
35134           IA=KFPR(ISUBSV,2)
35135           PMF=PYMRUN(IA,SH)
35136           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35137      &    (0.5D0*PMF/PMAS(24,1))**2
35138           WID2=1D0
35139           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35140           FACQQH=FACQQH*WID2
35141           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35142             IKFI=1
35143             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35144             IF(IA.GT.10) IKFI=3
35145             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35146             IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35147               FACQQH=FACQQH/(1D0+RMSS(41))**2
35148               IF(IHIGG.NE.3) THEN
35149                 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35150      &          PARU(151+10*IHIGG))**2
35151               ENDIF
35152             ENDIF
35153           ENDIF
35154           CALL PYQQBH(WTQQBH)
35155           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35156           HS=SHR*WDTP(0)
35157           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35158           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35159           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35160      &    FACBW=0D0
35161           NCHN=NCHN+1
35162           ISIG(NCHN,1)=21
35163           ISIG(NCHN,2)=21
35164           ISIG(NCHN,3)=1
35165           SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35166   460     CONTINUE
35167  
35168         ELSEIF(ISUB.EQ.122) THEN
35169 C...q + qbar -> Q + Qbar + h0
35170           IA=KFPR(ISUBSV,2)
35171           PMF=PYMRUN(IA,SH)
35172           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35173      &    (0.5D0*PMF/PMAS(24,1))**2
35174           WID2=1D0
35175           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35176           FACQQH=FACQQH*WID2
35177           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35178             IKFI=1
35179             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35180             IF(IA.GT.10) IKFI=3
35181             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35182             IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35183               FACQQH=FACQQH/(1D0+RMSS(41))**2
35184               IF(IHIGG.NE.3) THEN
35185                 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35186      &          PARU(151+10*IHIGG))**2
35187               ENDIF
35188             ENDIF
35189           ENDIF
35190           CALL PYQQBH(WTQQBH)
35191           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35192           HS=SHR*WDTP(0)
35193           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35194           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35195           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35196      &    FACBW=0D0
35197           DO 470 I=MMINA,MMAXA
35198             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35199      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
35200             NCHN=NCHN+1
35201             ISIG(NCHN,1)=I
35202             ISIG(NCHN,2)=-I
35203             ISIG(NCHN,3)=1
35204             SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35205   470     CONTINUE
35206  
35207         ELSEIF(ISUB.EQ.123) THEN
35208 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
35209 C...inner process)
35210           FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
35211           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35212      &    PARU(154+10*IHIGG)**2
35213           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35214      &    (VINT(216)-VINT(209)**2))**2
35215           FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35216           FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
35217           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35218           HS=SHR*WDTP(0)
35219           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35220           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35221           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35222      &    FACBW=0D0
35223           DO 490 I=MMIN1,MMAX1
35224             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
35225             IA=IABS(I)
35226             DO 480 J=MMIN2,MMAX2
35227               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
35228               JA=IABS(J)
35229               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
35230               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
35231               VI=AI-4D0*EI*XWV
35232               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
35233               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
35234               VJ=AJ-4D0*EJ*XWV
35235               FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
35236               FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
35237               NCHN=NCHN+1
35238               ISIG(NCHN,1)=I
35239               ISIG(NCHN,2)=J
35240               ISIG(NCHN,3)=1
35241               SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
35242   480       CONTINUE
35243   490     CONTINUE
35244  
35245         ELSEIF(ISUB.EQ.124) THEN
35246 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
35247 C...inner process)
35248           FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
35249           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35250      &    PARU(155+10*IHIGG)**2
35251           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35252      &    (VINT(216)-VINT(209)**2))**2
35253           FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35254           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35255           HS=SHR*WDTP(0)
35256           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35257           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35258           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35259      &    FACBW=0D0
35260           DO 510 I=MMIN1,MMAX1
35261             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
35262             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
35263             DO 500 J=MMIN2,MMAX2
35264               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
35265               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
35266               IF(EI*EJ.GT.0D0) GOTO 500
35267               FACLR=VINT(180+I)*VINT(180+J)
35268               NCHN=NCHN+1
35269               ISIG(NCHN,1)=I
35270               ISIG(NCHN,2)=J
35271               ISIG(NCHN,3)=1
35272               SIGH(NCHN)=FACLR*FACWW*FACBW
35273   500       CONTINUE
35274   510     CONTINUE
35275  
35276         ELSEIF(ISUB.EQ.143) THEN
35277 C...f + fbar' -> H+/-
35278           SQMHC=PMAS(37,1)**2
35279           CALL PYWIDT(37,SH,WDTP,WDTE)
35280           HS=SHR*WDTP(0)
35281           FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
35282           HP=AEM/(8D0*XW)*SH/SQMW*SH
35283           DO 530 I=MMIN1,MMAX1
35284             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
35285             IA=IABS(I)
35286             IM=(MOD(IA,10)+1)/2
35287             DO 520 J=MMIN2,MMAX2
35288               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
35289               JA=IABS(J)
35290               JM=(MOD(JA,10)+1)/2
35291               IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
35292               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35293      &        GOTO 520
35294               IF(MOD(IA,2).EQ.0) THEN
35295                 IU=IA
35296                 IL=JA
35297               ELSE
35298                 IU=JA
35299                 IL=IA
35300               ENDIF
35301               RML=PYMRUN(IL,SH)**2/SH
35302               RMU=PYMRUN(IU,SH)**2/SH
35303               HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
35304               IF(IA.LE.10) HI=HI*FACA/3D0
35305               KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35306               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
35307               NCHN=NCHN+1
35308               ISIG(NCHN,1)=I
35309               ISIG(NCHN,2)=J
35310               ISIG(NCHN,3)=1
35311               SIGH(NCHN)=HI*FACBW*HF
35312   520       CONTINUE
35313   530     CONTINUE
35314  
35315         ELSEIF(ISUB.EQ.161) THEN
35316 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
35317 C...(choice of only b and t to avoid kinematics problems)
35318           FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
35319 C...H propagator: as simulated in PYOFSH and as desired
35320           SQMHC=PMAS(37,1)**2
35321           GMMHC=PMAS(37,1)*PMAS(37,2)
35322           HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
35323           CALL PYWIDT(37,SQM4,WDTP,WDTE)
35324           GMMHCC=SQRT(SQM4)*WDTP(0)
35325           HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
35326           FHCQ=FHCQ*HBW4C/HBW4
35327           Q2RM=SH
35328           IF(MSTP(32).EQ.12) Q2RM=PARP(194)
35329           DO 550 I=MMINA,MMAXA
35330             IA=IABS(I)
35331             IF(IA.NE.5) GOTO 550
35332             SQML=PYMRUN(IA,Q2RM)**2
35333             IUA=IA+MOD(IA,2)
35334             SQMQ=PYMRUN(IUA,Q2RM)**2
35335             FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
35336      &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
35337      &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
35338      &      (SQMHC-SQMQ-SH)/SH)
35339             KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
35340             DO 540 ISDE=1,2
35341               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
35342               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
35343               NCHN=NCHN+1
35344               ISIG(NCHN,ISDE)=I
35345               ISIG(NCHN,3-ISDE)=21
35346               ISIG(NCHN,3)=1
35347               SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
35348               IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
35349   540       CONTINUE
35350   550     CONTINUE
35351         ENDIF
35352  
35353       ELSEIF(ISUB.LE.402) THEN
35354         IF(ISUB.EQ.401) THEN
35355 C...  g + g -> t + bbar + H-
35356           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
35357           IA=KFPR(ISUBSV,2)
35358           CALL PYSTBH(WTTBH)
35359           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35360           HS=SHR*WDTP(0)
35361           FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35362           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35363      &       FACBW=0D0
35364           NCHN=NCHN+1
35365           ISIG(NCHN,1)=21
35366           ISIG(NCHN,2)=21
35367           ISIG(NCHN,3)=1
35368           SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35369 c     Since we don't know yet if H+ or H-, assume H+
35370 c     when calculating suppression due to closed channels.
35371           SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35372           IF(ABS(WIDS(37,2)-WIDS(37,3))
35373      &       .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
35374      &       ABS(WIDS(6,2)-WIDS(6,3))
35375      &       .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
35376             WRITE(*,*)'Error: Process 401 cannot handle different'
35377             WRITE(*,*)'decays for H+ and H- or t and tbar.'
35378             WRITE(*,*)'Execution stopped.'
35379             CALL PYSTOP(108)
35380           END IF
35381  560      CONTINUE
35382  
35383         ELSEIF(ISUB.EQ.402) THEN
35384 C...  q + qbar -> t + bbar + H-
35385           IA=KFPR(ISUBSV,2)
35386           CALL PYSTBH(WTTBH)
35387           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35388           HS=SHR*WDTP(0)
35389           FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35390           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35391      &       FACBW=0D0
35392           DO 570 I=MMINA,MMAXA
35393             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35394      &         KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
35395             NCHN=NCHN+1
35396             ISIG(NCHN,1)=I
35397             ISIG(NCHN,2)=-I
35398             ISIG(NCHN,3)=1
35399             SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35400 c     Since we don't know yet if H+ or H-, assume H+
35401 c     when calculating suppression due to closed channels.
35402             SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35403             IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
35404      &         .GE.1D-6.OR.
35405      &         ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
35406      &         .GE.1D-6) THEN
35407               WRITE(*,*)'Error: Process 402 cannot handle different'
35408               WRITE(*,*)'decays for H+ and H- or t and tbar.'
35409               WRITE(*,*)'Execution stopped.'
35410               CALL PYSTOP(108)
35411             END IF
35412  570      CONTINUE
35413         ENDIF
35414       ENDIF
35415  
35416       RETURN
35417       END
35418  
35419 C*********************************************************************
35420  
35421 C...PYSGSU
35422 C...Subprocess cross sections for SUSY processes,
35423 C...including Higgs pair production.
35424 C...Auxiliary to PYSIGH.
35425  
35426       SUBROUTINE PYSGSU(NCHN,SIGS)
35427  
35428 C...Double precision and integer declarations
35429       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35430       IMPLICIT INTEGER(I-N)
35431       INTEGER PYK,PYCHGE,PYCOMP
35432 C...Parameter statement to help give large particle numbers.
35433       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35434      &KEXCIT=4000000,KDIMEN=5000000)
35435 C...Commonblocks
35436       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35437       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35438       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35439       COMMON/PYINT1/MINT(400),VINT(400)
35440       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35441       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35442       COMMON/PYINT4/MWID(500),WIDS(500,5)
35443       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35444       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35445      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35446       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35447      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35448      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35449      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35450       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
35451      &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
35452 C...Local arrays and complex variables
35453       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35454       COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
35455       COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
35456       COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
35457  
35458 CMRENNA++
35459 C...Z and W width, combinations of weak mixing angle
35460       ZWID=PMAS(23,2)
35461       WWID=PMAS(24,2)
35462       TANW=SQRT(XW/XW1)
35463       CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35464  
35465 C...Convert almost equivalent SUSY processes into each other
35466 C...Extract differences in flavours and couplings
35467  
35468 C...Sleptons and sneutrinos
35469       IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
35470         KFID=MOD(KFPR(ISUB,1),KSUSY1)
35471         ISUB=201
35472         ILR=0
35473       ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
35474         KFID=MOD(KFPR(ISUB,1),KSUSY1)
35475         ISUB=201
35476         ILR=1
35477       ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
35478         KFID=MOD(KFPR(ISUB,1),KSUSY1)
35479         ISUB=203
35480       ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
35481         IF(ISUB.EQ.210) THEN
35482           RKF=2.0D0
35483         ELSEIF(ISUB.EQ.211) THEN
35484           RKF=SFMIX(15,1)**2
35485         ELSEIF(ISUB.EQ.212) THEN
35486           RKF=SFMIX(15,2)**2
35487         ENDIF
35488           ISUB=210
35489       ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
35490         IF(ISUB.EQ.213) THEN
35491           KFID=MOD(KFPR(ISUB,1),KSUSY1)
35492           RKF=2.0D0
35493         ELSEIF(ISUB.EQ.214) THEN
35494           KFID=16
35495           RKF=1.0D0
35496         ENDIF
35497         ISUB=213
35498  
35499 C...Neutralinos
35500       ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
35501         IF(ISUB.EQ.216) THEN
35502           IZID1=1
35503           IZID2=1
35504         ELSEIF(ISUB.EQ.217) THEN
35505           IZID1=2
35506           IZID2=2
35507         ELSEIF(ISUB.EQ.218) THEN
35508           IZID1=3
35509           IZID2=3
35510         ELSEIF(ISUB.EQ.219) THEN
35511           IZID1=4
35512           IZID2=4
35513         ELSEIF(ISUB.EQ.220) THEN
35514           IZID1=1
35515           IZID2=2
35516         ELSEIF(ISUB.EQ.221) THEN
35517           IZID1=1
35518           IZID2=3
35519         ELSEIF(ISUB.EQ.222) THEN
35520           IZID1=1
35521           IZID2=4
35522         ELSEIF(ISUB.EQ.223) THEN
35523           IZID1=2
35524           IZID2=3
35525         ELSEIF(ISUB.EQ.224) THEN
35526           IZID1=2
35527           IZID2=4
35528         ELSEIF(ISUB.EQ.225) THEN
35529           IZID1=3
35530           IZID2=4
35531         ENDIF
35532         ISUB=216
35533  
35534 C...Charginos
35535       ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
35536         IF(ISUB.EQ.226) THEN
35537           IZID1=1
35538           IZID2=1
35539         ELSEIF(ISUB.EQ.227) THEN
35540           IZID1=2
35541           IZID2=2
35542         ELSEIF(ISUB.EQ.228) THEN
35543           IZID1=1
35544           IZID2=2
35545         ENDIF
35546         ISUB=226
35547  
35548 C...Neutralino + chargino
35549       ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
35550         IF(ISUB.EQ.229) THEN
35551           IZID1=1
35552           IZID2=1
35553         ELSEIF(ISUB.EQ.230) THEN
35554           IZID1=1
35555           IZID2=2
35556         ELSEIF(ISUB.EQ.231) THEN
35557           IZID1=1
35558           IZID2=3
35559         ELSEIF(ISUB.EQ.232) THEN
35560           IZID1=1
35561           IZID2=4
35562         ELSEIF(ISUB.EQ.233) THEN
35563           IZID1=2
35564           IZID2=1
35565         ELSEIF(ISUB.EQ.234) THEN
35566           IZID1=2
35567           IZID2=2
35568         ELSEIF(ISUB.EQ.235) THEN
35569           IZID1=2
35570           IZID2=3
35571         ELSEIF(ISUB.EQ.236) THEN
35572           IZID1=2
35573           IZID2=4
35574         ENDIF
35575         ISUB=229
35576  
35577 C...Gluino + neutralino
35578       ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
35579         IF(ISUB.EQ.237) THEN
35580           IZID=1
35581         ELSEIF(ISUB.EQ.238) THEN
35582           IZID=2
35583         ELSEIF(ISUB.EQ.239) THEN
35584           IZID=3
35585         ELSEIF(ISUB.EQ.240) THEN
35586           IZID=4
35587         ENDIF
35588         ISUB=237
35589  
35590 C...Gluino + chargino
35591       ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
35592         IF(ISUB.EQ.241) THEN
35593           IZID=1
35594         ELSEIF(ISUB.EQ.242) THEN
35595           IZID=2
35596         ENDIF
35597         ISUB=241
35598  
35599 C...Squark + neutralino
35600       ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
35601         ILR=0
35602         IF(MOD(ISUB,2).NE.0) ILR=1
35603         IF(ISUB.LE.247) THEN
35604           IZID=1
35605         ELSEIF(ISUB.LE.249) THEN
35606           IZID=2
35607         ELSEIF(ISUB.LE.251) THEN
35608           IZID=3
35609         ELSEIF(ISUB.LE.253) THEN
35610           IZID=4
35611         ENDIF
35612         ISUB=246
35613         RKF=5D0
35614  
35615 C...Squark + chargino
35616       ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
35617         IF(ISUB.LE.255) THEN
35618           IZID=1
35619         ELSEIF(ISUB.LE.257) THEN
35620           IZID=2
35621         ENDIF
35622         IF(MOD(ISUB,2).EQ.0) THEN
35623           ILR=0
35624         ELSE
35625           ILR=1
35626         ENDIF
35627         ISUB=254
35628         RKF=5D0
35629  
35630 C...Squark + gluino
35631       ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
35632         ISUB=258
35633         RKF=4D0
35634  
35635 C...Stops
35636       ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
35637         ILR=0
35638         IF(ISUB.EQ.262) ILR=1
35639         ISUB=261
35640       ELSEIF(ISUB.EQ.265) THEN
35641         ISUB=264
35642  
35643 C...Squarks
35644       ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
35645         ILR=0
35646         IF(ISUB.LE.273) THEN
35647           IF(ISUB.EQ.273) ILR=1
35648           ISUB=271
35649           RKF=16D0
35650         ELSEIF(ISUB.LE.276) THEN
35651           IF(ISUB.EQ.276) ILR=1
35652           ISUB=274
35653           RKF=16D0
35654         ELSEIF(ISUB.LE.278) THEN
35655           IF(ISUB.EQ.278) ILR=1
35656           ISUB=277
35657           RKF=4D0
35658         ELSE
35659           IF(ISUB.EQ.280) ILR=1
35660           ISUB=279
35661           RKF=4D0
35662         ENDIF
35663 C...Sbottoms
35664       ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35665         ILR=0
35666         IF(ISUB.LE.283) THEN
35667           IF(ISUB.EQ.283) ILR=1
35668           ISUB=271
35669           RKF=4D0
35670         ELSEIF(ISUB.LE.286) THEN
35671           IF(ISUB.EQ.286) ILR=1
35672           ISUB=274
35673           RKF=4D0
35674         ELSEIF(ISUB.LE.288) THEN
35675           IF(ISUB.EQ.288) ILR=1
35676           ISUB=277
35677           RKF=1D0
35678         ELSEIF(ISUB.LE.290) THEN
35679           IF(ISUB.EQ.290) ILR=1
35680           ISUB=279
35681           RKF=1D0
35682         ELSEIF(ISUB.LE.293) THEN
35683           IF(ISUB.EQ.293) ILR=1
35684           ISUB=271
35685           RKF=1D0
35686         ELSEIF(ISUB.EQ.296) THEN
35687           ILR=1
35688           ISUB=274
35689           RKF=1D0
35690 C...Squark + gluino
35691         ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35692           ISUB=258
35693           RKF=1D0
35694         ENDIF
35695 C...H+/- + H0
35696       ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35697         IF(ISUB.EQ.297) THEN
35698           RKF=.5D0*PARU(195)**2
35699         ELSEIF(ISUB.EQ.298) THEN
35700           RKF=.5D0*(1D0-PARU(195)**2)
35701         ENDIF
35702         ISUB=210
35703 C...A0 + H0
35704       ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35705         IF(ISUB.EQ.299) THEN
35706           RKF=PARU(186)**2
35707           KFID=25
35708         ELSEIF(ISUB.EQ.300) THEN
35709           RKF=PARU(187)**2
35710           KFID=35
35711         ENDIF
35712         ISUB=213
35713 C...H+ + H-
35714       ELSEIF(ISUB.EQ.301) THEN
35715         KFID=37
35716         RKF=1D0
35717         ISUB=201
35718       ENDIF
35719  
35720 C...Supersymmetric processes - all of type 2 -> 2 :
35721 C...correct final-state Breit-Wigners from fixed to running width.
35722       IF(MSTP(42).GT.0) THEN
35723         DO 100 I=1,2
35724         KFLW=KFPR(ISUBSV,I)
35725         KCW=PYCOMP(KFLW)
35726         IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35727         IF(I.EQ.1) SQMI=SQM3
35728         IF(I.EQ.2) SQMI=SQM4
35729         SQMS=PMAS(KCW,1)**2
35730         GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35731         HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35732         CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35733         GMMI=SQRT(SQMI)*WDTP(0)
35734         HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35735         COMFAC=COMFAC*(HBWI/HBWS)
35736   100   CONTINUE
35737       ENDIF
35738  
35739 C...Differential cross section expressions.
35740  
35741       IF(ISUB.LE.210) THEN
35742         IF(ISUB.EQ.201) THEN
35743 C...f + fbar -> e_L + e_Lbar
35744           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35745           DO 130 I=MMIN1,MMAX1
35746             IA=IABS(I)
35747             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35748             EI=KCHG(IA,1)/3D0
35749             TT3I=SIGN(1D0,EI+1D-6)/2D0
35750             EJ=-1D0
35751             TT3J=-1D0/2D0
35752             FCOL=1D0
35753 C...Color factor for e+ e-
35754             IF(IA.GE.11) FCOL=3D0
35755             IF(ISUBSV.EQ.301) THEN
35756               A1=1D0
35757               A2=0D0
35758             ELSEIF(ILR.EQ.1) THEN
35759               A1=SFMIX(KFID,3)**2
35760               A2=SFMIX(KFID,4)**2
35761             ELSEIF(ILR.EQ.0) THEN
35762               A1=SFMIX(KFID,1)**2
35763               A2=SFMIX(KFID,2)**2
35764             ENDIF
35765             XLQ=(TT3J-EJ*XW)*A1
35766             XRQ=(-EJ*XW)*A2
35767             XLF=(TT3I-EI*XW)
35768             XRF=(-EI*XW)
35769             TAA=(EI*EJ)**2*(POLL+POLR)
35770             TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35771             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35772             TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35773             TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35774             TNN=0.0D0
35775             TAN=0.0D0
35776             TZN=0.0D0
35777             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35778               FAC2=SQRT(2D0)
35779               TNN1=0D0
35780               TNN2=0D0
35781               TNN3=0D0
35782               DO 120 II=1,4
35783                 DK=1D0/(TH-SMZ(II)**2)
35784                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35785      &          ZMIX(II,1))
35786                 FREK=FAC2*TANW*EI*ZMIX(II,1)
35787                 TNN1=TNN1+FLEK**2*DK
35788                 TNN2=TNN2+FREK**2*DK
35789                 DO 110 JJ=1,4
35790                   DL=1D0/(TH-SMZ(JJ)**2)
35791                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35792      &            ZMIX(JJ,1))
35793                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35794                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35795   110           CONTINUE
35796   120         CONTINUE
35797               TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35798      &        A2**2*TNN2**2*POLR)
35799               TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35800      &        (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35801               TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35802      &        (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35803               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35804      &        (1D0-SQMZ/SH)/SH
35805               TZN=TZN/XW**2/XW1
35806               TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35807      &        A2*TNN2*POLR)/XW
35808             ENDIF
35809             FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35810             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35811             FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35812             NCHN=NCHN+1
35813             ISIG(NCHN,1)=I
35814             ISIG(NCHN,2)=-I
35815             ISIG(NCHN,3)=1
35816             SIGH(NCHN)=FACQQ1+FACQQ2
35817   130     CONTINUE
35818  
35819         ELSEIF(ISUB.EQ.203) THEN
35820 C...f + fbar -> e_L + e_Rbar
35821           DO 160 I=MMIN1,MMAX1
35822             IA=IABS(I)
35823             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35824             EI=KCHG(IABS(I),1)/3D0
35825             TT3I=SIGN(1D0,EI)/2D0
35826             EJ=-1
35827             TT3J=-1D0/2D0
35828             FCOL=1D0
35829 C...Color factor for e+ e-
35830             IF(IA.GE.11) FCOL=3D0
35831             A1=SFMIX(KFID,1)**2
35832             A2=SFMIX(KFID,2)**2
35833             XLQ=(TT3J-EJ*XW)
35834             XRQ=(-EJ*XW)
35835             XLF=(TT3I-EI*XW)
35836             XRF=(-EI*XW)
35837             TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35838      &      /XW**2/XW1**2*A1*A2
35839             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35840             TNN=0.0D0
35841             TZN=0.0D0
35842             TNNA=0D0
35843             TNNB=0D0
35844             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35845               FAC2=SQRT(2D0)
35846               TNN1=0D0
35847               TNN2=0D0
35848               TNN3=0D0
35849               DO 150 II=1,4
35850                 DK=1D0/(TH-SMZ(II)**2)
35851                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35852      &          ZMIX(II,1))
35853                 FREK=FAC2*TANW*EI*ZMIX(II,1)
35854                 TNN1=TNN1+FLEK**2*DK
35855                 TNN2=TNN2+FREK**2*DK
35856                 DO 140 JJ=1,4
35857                   DL=1D0/(TH-SMZ(JJ)**2)
35858                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35859      &            ZMIX(JJ,1))
35860                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35861                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35862   140           CONTINUE
35863   150         CONTINUE
35864               TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35865               TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35866               TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35867               TZN=(UH*TH-SQM3*SQM4)*A1*A2
35868               TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35869               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35870      &        (1D0-SQMZ/SH)/SH
35871             ENDIF
35872             FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35873             FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35874             FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35875 C%%%%%%%%%%%
35876             NCHN=NCHN+1
35877             ISIG(NCHN,1)=I
35878             ISIG(NCHN,2)=-I
35879             ISIG(NCHN,3)=1
35880             SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35881      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35882             NCHN=NCHN+1
35883             ISIG(NCHN,1)=I
35884             ISIG(NCHN,2)=-I
35885             ISIG(NCHN,3)=2
35886             SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35887      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35888   160     CONTINUE
35889  
35890         ELSEIF(ISUB.EQ.210) THEN
35891 C...q + qbar' -> W*- > ~l_L + ~nu_L
35892           FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35893           FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35894           DO 180 I=MMIN1,MMAX1
35895             IA=IABS(I)
35896             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35897             DO 170 J=MMIN2,MMAX2
35898               JA=IABS(J)
35899               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35900               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35901               FCKM=3D0
35902               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35903               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35904               KCHW=2
35905               IF(KCHSUM.LT.0) KCHW=3
35906               NCHN=NCHN+1
35907               ISIG(NCHN,1)=I
35908               ISIG(NCHN,2)=J
35909               ISIG(NCHN,3)=1
35910               IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35911                 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35912      &          WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35913               ELSE
35914                 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35915      &          WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35916               ENDIF
35917               SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35918   170       CONTINUE
35919   180     CONTINUE
35920         ENDIF
35921  
35922       ELSEIF(ISUB.LE.220) THEN
35923         IF(ISUB.EQ.213) THEN
35924 C...f + fbar -> ~nu_L + ~nu_Lbar
35925           IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35926             FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35927      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35928           ELSE
35929             FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35930           ENDIF
35931           COMFAC=COMFAC*FACR
35932           PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35933           XLL=0.5D0
35934           XLR=0.0D0
35935           DO 190 I=MMIN1,MMAX1
35936             IA=IABS(I)
35937             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35938             EI=KCHG(IA,1)/3D0
35939             FCOL=1D0
35940 C...Color factor for e+ e-
35941             IF(IA.GE.11) FCOL=3D0
35942             XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35943             XRQ=-EI*XW
35944             TZC=0.0D0
35945             TCC=0.0D0
35946             IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35947               TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35948      &        (TH-SMW(2)**2)
35949               TCC=TZC**2
35950               TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35951             ENDIF
35952             FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35953             FACQQ2=TZC+TCC/4D0
35954             NCHN=NCHN+1
35955             ISIG(NCHN,1)=I
35956             ISIG(NCHN,2)=-I
35957             ISIG(NCHN,3)=1
35958             SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35959      &      *AEM**2*FCOL/3D0/XW**2
35960   190     CONTINUE
35961  
35962         ELSEIF(ISUB.EQ.216) THEN
35963 C...q + qbar -> ~chi0_1 + ~chi0_1
35964           IF(IZID1.EQ.IZID2) THEN
35965             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35966           ELSE
35967             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35968      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35969           ENDIF
35970           FACXX=COMFAC*AEM**2/3D0/XW**2
35971           IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35972           ZM12=SQM3
35973           ZM22=SQM4
35974           WU2 = (UH-ZM12)*(UH-ZM22)
35975           WT2 = (TH-ZM12)*(TH-ZM22)
35976           WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35977           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35978           PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35979           DO 200 I=1,4
35980             ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35981             IF(IZID2.NE.IZID1) THEN
35982               ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35983             ENDIF
35984   200     CONTINUE
35985           OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35986      &    ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35987           ORPP=DCONJG(OLPP)
35988           DO 210 I=MMINA,MMAXA
35989             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35990             EI=KCHG(IABS(I),1)/3D0
35991             T3I=SIGN(1D0,EI+1D-6)/2D0
35992             XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35993             XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35994             GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35995      &      DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35996             GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35997             QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35998             QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35999      &      /DCMPLX(TH-XML2)
36000             QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
36001             QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
36002      &      -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
36003             FCOL=1D0
36004             IF(IABS(I).GE.11) FCOL=3D0
36005             FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36006      &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36007      &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36008      &      QRL*DCONJG(QRR)*POLR)*WS2
36009             NCHN=NCHN+1
36010             ISIG(NCHN,1)=I
36011             ISIG(NCHN,2)=-I
36012             ISIG(NCHN,3)=1
36013             SIGH(NCHN)=FACXX*FACGG1*FCOL
36014   210     CONTINUE
36015         ENDIF
36016  
36017       ELSEIF(ISUB.LE.230) THEN
36018         IF(ISUB.EQ.226) THEN
36019 C...f + fbar -> ~chi+_1 + ~chi-_1
36020           FACXX=COMFAC*AEM**2/3D0
36021           ZM12=SQM3
36022           ZM22=SQM4
36023           WU2 = (UH-ZM12)*(UH-ZM22)
36024           WT2 = (TH-ZM12)*(TH-ZM22)
36025           WS2 = SMW(IZID1)*SMW(IZID2)*SH
36026           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
36027           PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
36028           DIFF=0D0
36029           IF(IZID1.EQ.IZID2) DIFF=1D0
36030           DO 220 I=1,2
36031             VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36032             UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36033             IF(IZID2.NE.IZID1) THEN
36034               VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
36035               UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
36036             ENDIF
36037   220     CONTINUE
36038           OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
36039      &    VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
36040           ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
36041      &    UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
36042           DO 230 I=MMINA,MMAXA
36043             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
36044             EI=KCHG(IABS(I),1)/3D0
36045             T3I=SIGN(1D0,EI+1D-6)/2D0
36046             QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
36047             QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
36048             QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
36049             IF(MOD(I,2).EQ.0) THEN
36050               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
36051               QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36052      &        PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
36053      &        DCMPLX(T3I/XW/(TH-XML2))
36054             ELSE
36055               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
36056               QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36057      &        PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
36058      &        DCMPLX(T3I/XW/(TH-XML2))
36059             ENDIF
36060             FCOL=1D0
36061             IF(IABS(I).GE.11) FCOL=3D0
36062             FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36063      &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36064      &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36065      &      QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
36066             NCHN=NCHN+1
36067             ISIG(NCHN,1)=I
36068             ISIG(NCHN,2)=-I
36069             ISIG(NCHN,3)=1
36070             IF(IZID1.EQ.IZID2) THEN
36071               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36072             ELSE
36073               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36074      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36075               NCHN=NCHN+1
36076               ISIG(NCHN,1)=I
36077               ISIG(NCHN,2)=-I
36078               ISIG(NCHN,3)=2
36079               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36080      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36081             ENDIF
36082   230     CONTINUE
36083  
36084         ELSEIF(ISUB.EQ.229) THEN
36085 C...q + qbar' -> ~chi0_1 + ~chi+-_1
36086           FACXX=COMFAC*AEM**2/6D0/XW**2
36087           ZM12=SQM3
36088           ZM22=SQM4
36089           WU2 = (UH-ZM12)*(UH-ZM22)
36090           WT2 = (TH-ZM12)*(TH-ZM22)
36091           WS2 = SMW(IZID1)*SMZ(IZID2)*SH
36092           RT2I = 1D0/SQRT(2D0)
36093           PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
36094      &    DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
36095           DO 240 I=1,2
36096             VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36097             UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36098   240     CONTINUE
36099           DO 250 I=1,4
36100             ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
36101   250     CONTINUE
36102           OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
36103      &    DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
36104           OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
36105      &    ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
36106  
36107           DO 270 I=MMIN1,MMAX1
36108             IA=IABS(I)
36109             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
36110             EI=KCHG(IA,1)/3D0
36111             T3I=SIGN(1D0,EI+1D-6)/2D0
36112             DO 260 J=MMIN2,MMAX2
36113               JA=IABS(J)
36114               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
36115               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
36116               EJ=KCHG(JA,1)/3D0
36117               T3J=SIGN(1D0,EJ+1D-6)/2D0
36118               FCKM=3D0
36119               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36120               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36121               KCHW=2
36122               IF(KCHSUM.LT.0) KCHW=3
36123               IF(MOD(IA,2).EQ.0) THEN
36124                 ZMI2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
36125                 ZMJ2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
36126                 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
36127      &          TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
36128                 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36129      &          ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
36130      &          /DCMPLX(TH-ZMJ2)
36131               ELSE
36132                 ZMI2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
36133                 ZMJ2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
36134                 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
36135      &          TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
36136                 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36137      &          ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
36138      &          /DCMPLX(TH-ZMI2)
36139               ENDIF
36140               ZINTR=DBLE(QLR*DCONJG(QLL))
36141               FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
36142      &        2D0*ZINTR*WS2)
36143               NCHN=NCHN+1
36144               ISIG(NCHN,1)=I
36145               ISIG(NCHN,2)=J
36146               ISIG(NCHN,3)=1
36147               SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36148      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36149   260       CONTINUE
36150   270     CONTINUE
36151         ENDIF
36152  
36153       ELSEIF(ISUB.LE.240) THEN
36154         IF(ISUB.EQ.237) THEN
36155 C...q + qbar -> gluino + ~chi0_1
36156           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36157      &    WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36158           ASYUK=RMSS(42)*AS
36159           FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
36160           GM2=SQM3
36161           ZM2=SQM4
36162           DO 280 I=MMINA,MMAXA
36163             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36164      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
36165             EI=KCHG(IABS(I),1)/3D0
36166             IA=IABS(I)
36167             XLQC = -TANW*EI*ZMIX(IZID,1)
36168             XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36169      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36170             XLQ2=XLQC**2
36171             XRQ2=XRQC**2
36172             XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
36173             XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
36174             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
36175             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
36176             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
36177             SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36178             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
36179             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
36180             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
36181             SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36182             NCHN=NCHN+1
36183             ISIG(NCHN,1)=I
36184             ISIG(NCHN,2)=-I
36185             ISIG(NCHN,3)=1
36186             SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
36187   280     CONTINUE
36188         ENDIF
36189  
36190       ELSEIF(ISUB.LE.250) THEN
36191         IF(ISUB.EQ.241) THEN
36192 C...q + qbar' -> ~chi+-_1 + gluino
36193           FACWG=COMFAC*AS*AEM/XW*2D0/9D0
36194           GM2=SQM3
36195           ZM2=SQM4
36196           FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
36197           FAC0=UMIX(IZID,1)**2
36198           FAC1=VMIX(IZID,1)**2
36199           DO 300 I=MMIN1,MMAX1
36200             IA=IABS(I)
36201             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
36202             DO 290 J=MMIN2,MMAX2
36203               JA=IABS(J)
36204               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
36205               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
36206               FCKM=1D0
36207               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36208               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36209               KCHW=2
36210               IF(KCHSUM.LT.0) KCHW=3
36211               XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
36212               XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
36213               ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
36214               AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
36215               ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
36216               XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
36217               XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
36218               ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
36219               AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
36220               ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
36221      &        SH/(TH-XMU2)/(UH-XMD2))/2D0
36222               NCHN=NCHN+1
36223               ISIG(NCHN,1)=I
36224               ISIG(NCHN,2)=J
36225               ISIG(NCHN,3)=1
36226               SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
36227      &        FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36228      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36229   290       CONTINUE
36230   300     CONTINUE
36231  
36232         ELSEIF(ISUB.EQ.243) THEN
36233 C...q + qbar -> gluino + gluino
36234           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36235           XMT=SQM3-TH
36236           XMU=SQM3-UH
36237           DO 310 I=MMINA,MMAXA
36238             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36239      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
36240             NCHN=NCHN+1
36241             XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
36242             XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
36243             FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36244      &      2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36245      &      XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36246      &      (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36247             XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
36248             XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
36249             FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36250      &      2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36251      &      XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36252      &      (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36253             ISIG(NCHN,1)=I
36254             ISIG(NCHN,2)=-I
36255             ISIG(NCHN,3)=1
36256 C...1/2 for identical particles
36257             SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
36258   310     CONTINUE
36259  
36260         ELSEIF(ISUB.EQ.244) THEN
36261 C...g + g -> gluino + gluino
36262           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36263           XMT=SQM3-TH
36264           XMU=SQM3-UH
36265           FACQQ1=COMFAC*AS**2*9D0/4D0*(
36266      &    (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
36267      &    (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
36268           FACQQ2=COMFAC*AS**2*9D0/4D0*(
36269      &    (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
36270      &    (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
36271           FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
36272      &    SQM3*(SH-4D0*SQM3)/XMT/XMU)
36273           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
36274           NCHN=NCHN+1
36275           ISIG(NCHN,1)=21
36276           ISIG(NCHN,2)=21
36277           ISIG(NCHN,3)=1
36278           SIGH(NCHN)=FACQQ1/2D0
36279           NCHN=NCHN+1
36280           ISIG(NCHN,1)=21
36281           ISIG(NCHN,2)=21
36282           ISIG(NCHN,3)=2
36283           SIGH(NCHN)=FACQQ2/2D0
36284           NCHN=NCHN+1
36285           ISIG(NCHN,1)=21
36286           ISIG(NCHN,2)=21
36287           ISIG(NCHN,3)=3
36288           SIGH(NCHN)=FACQQ3/2D0
36289   320     CONTINUE
36290  
36291         ELSEIF(ISUB.EQ.246) THEN
36292 C...g + q_j -> ~chi0_1 + ~q_j
36293           FAC0=COMFAC*AS*AEM/6D0/XW
36294           ZM2=SQM4
36295           QM2=SQM3
36296           FACZQ0=FAC0*( (ZM2-TH)/SH +
36297      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36298      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36299           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36300           DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
36301             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
36302             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
36303             EI=KCHG(IABS(I),1)/3D0
36304             IA=IABS(I)
36305             XRQZ = -TANW*EI*ZMIX(IZID,1)
36306             XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36307      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36308             IF(ILR.EQ.0) THEN
36309               BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
36310             ELSE
36311               BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
36312             ENDIF
36313             FACZQ=FACZQ0*BS
36314             KCHQ=2
36315             IF(I.LT.0) KCHQ=3
36316             DO 330 ISDE=1,2
36317               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
36318               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
36319               NCHN=NCHN+1
36320               ISIG(NCHN,ISDE)=I
36321               ISIG(NCHN,3-ISDE)=21
36322               ISIG(NCHN,3)=1
36323               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36324      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36325   330       CONTINUE
36326   340     CONTINUE
36327         ENDIF
36328  
36329       ELSEIF(ISUB.LE.260) THEN
36330         IF(ISUB.EQ.254) THEN
36331 C...g + q_j -> ~chi1_1 + ~q_i
36332           FAC0=COMFAC*AS*AEM/12D0/XW
36333           ZM2=SQM4
36334           QM2=SQM3
36335           AU=UMIX(IZID,1)**2
36336           AD=VMIX(IZID,1)**2
36337           FACZQ0=FAC0*( (ZM2-TH)/SH +
36338      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36339      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36340           KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
36341           IF(MOD(KFNSQ1,2).EQ.0) THEN
36342             KFNSQ=KFNSQ1-1
36343             KCHW=2
36344           ELSE
36345             KFNSQ=KFNSQ1+1
36346             KCHW=3
36347           ENDIF
36348           DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
36349             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
36350             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
36351             IA=IABS(I)
36352             IF(MOD(IA,2).EQ.0) THEN
36353               FACZQ=FACZQ0*AU
36354             ELSE
36355               FACZQ=FACZQ0*AD
36356             ENDIF
36357             FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
36358             KCHQ=2
36359             IF(I.LT.0) KCHQ=3
36360             KCHWQ=KCHW
36361             IF(I.LT.0) KCHWQ=5-KCHW
36362             DO 350 ISDE=1,2
36363               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
36364               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
36365               NCHN=NCHN+1
36366               ISIG(NCHN,ISDE)=I
36367               ISIG(NCHN,3-ISDE)=21
36368               ISIG(NCHN,3)=1
36369               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36370      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
36371   350       CONTINUE
36372   360     CONTINUE
36373  
36374         ELSEIF(ISUB.EQ.258) THEN
36375 C...g + q_j -> gluino + ~q_i
36376           XG2=SQM4
36377           XQ2=SQM3
36378           XMT=XG2-TH
36379           XMU=XG2-UH
36380           XST=XQ2-TH
36381           XSU=XQ2-UH
36382           FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
36383      &    ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
36384      &    0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
36385      &    (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
36386           FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
36387      &    (SH*(UH+XG2)
36388      &    +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
36389      &    0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
36390      &    (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
36391           ASYUK=RMSS(42)*AS
36392           FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
36393           FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
36394           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36395           DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
36396             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
36397             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
36398             KCHQ=2
36399             IF(I.LT.0) KCHQ=3
36400             FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36401      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36402             DO 370 ISDE=1,2
36403               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
36404               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
36405               NCHN=NCHN+1
36406               ISIG(NCHN,ISDE)=I
36407               ISIG(NCHN,3-ISDE)=21
36408               ISIG(NCHN,3)=1
36409               SIGH(NCHN)=FACQG1*FACSEL
36410               NCHN=NCHN+1
36411               ISIG(NCHN,ISDE)=I
36412               ISIG(NCHN,3-ISDE)=21
36413               ISIG(NCHN,3)=2
36414               SIGH(NCHN)=FACQG2*FACSEL
36415   370       CONTINUE
36416   380     CONTINUE
36417         ENDIF
36418  
36419       ELSEIF(ISUB.LE.270) THEN
36420         IF(ISUB.EQ.261) THEN
36421 C...q_i + q_ibar -> ~t_1 + ~t_1bar
36422           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
36423      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36424           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36425           FAC0=AS**2*4D0/9D0
36426           DO 390 I=MMIN1,MMAX1
36427             IA=IABS(I)
36428             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
36429             IF(IA.GE.11.AND.IA.LE.18) THEN
36430               EI=KCHG(IA,1)/3D0
36431               EJ=KCHG(KFNSQ,1)/3D0
36432               T3I=SIGN(1D0,EI)/2D0
36433               T3J=SIGN(1D0,EJ)/2D0
36434               XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
36435               XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
36436               XLF=2D0*(T3I-EI*XW)
36437               XRF=2D0*(-EI*XW)
36438               TAA=0.5D0*(EI*EJ)**2
36439               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36440               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36441               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36442               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36443               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36444             ENDIF
36445             NCHN=NCHN+1
36446             ISIG(NCHN,1)=I
36447             ISIG(NCHN,2)=-I
36448             ISIG(NCHN,3)=1
36449             SIGH(NCHN)=FACQQ1*FAC0
36450   390     CONTINUE
36451  
36452         ELSEIF(ISUB.EQ.263) THEN
36453 C...f + fbar -> ~t1 + ~t2bar
36454           DO 400 I=MMIN1,MMAX1
36455             IA=IABS(I)
36456             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36457             EI=KCHG(IABS(I),1)/3D0
36458             TT3I=SIGN(1D0,EI)/2D0
36459             EJ=2D0/3D0
36460             TT3J=1D0/2D0
36461             FCOL=1D0
36462 C...Color factor for e+ e-
36463             IF(IA.GE.11) FCOL=3D0
36464             XLQ=2D0*(TT3J-EJ*XW)
36465             XRQ=2D0*(-EJ*XW)
36466             XLF=2D0*(TT3I-EI*XW)
36467             XRF=2D0*(-EI*XW)
36468             TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
36469             TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
36470             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36471 C...Factor of 2 for t1 t2bar + t2 t1bar
36472 C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
36473             FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0
36474             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
36475             NCHN=NCHN+1
36476             ISIG(NCHN,1)=I
36477             ISIG(NCHN,2)=-I
36478             ISIG(NCHN,3)=1
36479             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36480      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36481             NCHN=NCHN+1
36482             ISIG(NCHN,1)=I
36483             ISIG(NCHN,2)=-I
36484             ISIG(NCHN,3)=2
36485             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36486      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36487   400     CONTINUE
36488  
36489         ELSEIF(ISUB.EQ.264) THEN
36490 C...g + g -> ~t_1 + ~t_1bar
36491           XSU=SQM3-UH
36492           XST=SQM3-TH
36493           FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
36494      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36495           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36496           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36497           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
36498           NCHN=NCHN+1
36499           ISIG(NCHN,1)=21
36500           ISIG(NCHN,2)=21
36501           ISIG(NCHN,3)=1
36502           SIGH(NCHN)=FACQQ1
36503           NCHN=NCHN+1
36504           ISIG(NCHN,1)=21
36505           ISIG(NCHN,2)=21
36506           ISIG(NCHN,3)=2
36507           SIGH(NCHN)=FACQQ2
36508   410     CONTINUE
36509         ENDIF
36510  
36511       ELSEIF(ISUB.LE.280) THEN
36512         IF(ISUB.EQ.271) THEN
36513 C...q + q' -> ~q + ~q' (~g exchange)
36514           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36515           XMT=XMG2-TH
36516           XMU=XMG2-UH
36517           XSU1=SQM3-UH
36518           XSU2=SQM4-UH
36519           XST1=SQM3-TH
36520           XST2=SQM4-TH
36521           ASYUK=RMSS(42)*AS
36522           IF(ILR.EQ.1) THEN
36523             FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
36524             FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
36525             FACQQB=0.0D0
36526           ELSE
36527             FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
36528             FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
36529             FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
36530      &      XMT/XMU )
36531           ENDIF
36532           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36533           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36534           DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
36535             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
36536             IA=IABS(I)
36537             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36538             KCHQ=2
36539             IF(I.LT.0) KCHQ=3
36540             DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36541               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
36542               JA=IABS(J)
36543               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36544               IF(I*J.LT.0) GOTO 420
36545               NCHN=NCHN+1
36546               ISIG(NCHN,1)=I
36547               ISIG(NCHN,2)=J
36548               ISIG(NCHN,3)=1
36549               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36550      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36551               IF(I.EQ.J) THEN
36552                 IF(ILR.EQ.0) THEN
36553                   SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
36554      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36555                 ELSE
36556                   SIGH(NCHN)=0.5D0*FACQQ1*RKF*
36557      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36558      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36559                 ENDIF
36560                 NCHN=NCHN+1
36561                 ISIG(NCHN,1)=I
36562                 ISIG(NCHN,2)=J
36563                 ISIG(NCHN,3)=2
36564                 IF(ILR.EQ.0) THEN
36565                   SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
36566      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36567                 ELSE
36568                   SIGH(NCHN)=0.5D0*FACQQ2*RKF*
36569      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36570      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36571                 ENDIF
36572               ENDIF
36573   420       CONTINUE
36574   430     CONTINUE
36575  
36576         ELSEIF(ISUB.EQ.274) THEN
36577 C...q + qbar' -> ~q + ~qbar'
36578           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36579           XMT=XMG2-TH
36580           XMU=XMG2-UH
36581           IF(ILR.EQ.0) THEN
36582 C...Mrenna...Normalization.and.1/XMT
36583             FACQQ1=COMFAC*AS**2*2D0/9D0*(
36584      &      (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
36585             FACQQB=COMFAC*AS**2*4D0/9D0*(
36586      &      (UH*TH-SQM3*SQM4)/SH2 )
36587 C...Mrenna..Switched sign to agree with Eichten, Dawson, etc.
36588             FACQQI=COMFAC*AS**2*4D0/27D0*(
36589      &      (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
36590             FACQQB=FACQQB+FACQQ1+FACQQI
36591           ELSE
36592             FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
36593             FACQQB=FACQQ1
36594           ENDIF
36595           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36596           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36597           DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
36598             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
36599             IA=IABS(I)
36600             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
36601             KCHQ=2
36602             IF(I.LT.0) KCHQ=3
36603             DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36604               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
36605               JA=IABS(J)
36606               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
36607               IF(I*J.GT.0) GOTO 440
36608               NCHN=NCHN+1
36609               ISIG(NCHN,1)=I
36610               ISIG(NCHN,2)=J
36611               ISIG(NCHN,3)=1
36612               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36613      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
36614               IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
36615      &        WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36616   440       CONTINUE
36617   450     CONTINUE
36618  
36619         ELSEIF(ISUB.EQ.277) THEN
36620 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
36621 C...if i .eq. j covered in 274
36622           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
36623           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36624           FAC0=0D0
36625           DO 460 I=MMIN1,MMAX1
36626             IA=IABS(I)
36627             IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
36628      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36629             IF(IA.EQ.KFNSQ) GOTO 460
36630             IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
36631               EI=KCHG(IA,1)/3D0
36632               EJ=KCHG(KFNSQ,1)/3D0
36633               T3J=SIGN(0.5D0,EJ)
36634               T3I=SIGN(1D0,EI)/2D0
36635               IF(ILR.EQ.0) THEN
36636                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
36637                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
36638               ELSE
36639                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
36640                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
36641               ENDIF
36642               XLF=2D0*(T3I-EI*XW)
36643               XRF=2D0*(-EI*XW)
36644               IF(ILR.EQ.0) THEN
36645                 XRQ=0D0
36646               ELSE
36647                 XLQ=0D0
36648               ENDIF
36649               TAA=0.5D0*(EI*EJ)**2
36650               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36651               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36652               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36653               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36654               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36655             ELSEIF(IA.LE.6) THEN
36656               FAC0=AS**2*8D0/9D0/2D0
36657             ENDIF
36658             NCHN=NCHN+1
36659             ISIG(NCHN,1)=I
36660             ISIG(NCHN,2)=-I
36661             ISIG(NCHN,3)=1
36662             SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36663   460     CONTINUE
36664  
36665         ELSEIF(ISUB.EQ.279) THEN
36666 C...g + g -> ~q_j + ~q_jbar
36667           XSU=SQM3-UH
36668           XST=SQM3-TH
36669 C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
36670           FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36671           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36672           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36673           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36674           NCHN=NCHN+1
36675           ISIG(NCHN,1)=21
36676           ISIG(NCHN,2)=21
36677           ISIG(NCHN,3)=1
36678           SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36679           NCHN=NCHN+1
36680           ISIG(NCHN,1)=21
36681           ISIG(NCHN,2)=21
36682           ISIG(NCHN,3)=2
36683           SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36684   470     CONTINUE
36685  
36686         ENDIF
36687       ENDIF
36688 CMRENNA--
36689  
36690       RETURN
36691       END
36692  
36693 C*********************************************************************
36694  
36695 C...PYSGTC
36696 C...Subprocess cross sections for Technicolor processes.
36697 C...Auxiliary to PYSIGH.
36698  
36699       SUBROUTINE PYSGTC(NCHN,SIGS)
36700  
36701 C...Double precision and integer declarations
36702       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36703       IMPLICIT INTEGER(I-N)
36704       INTEGER PYK,PYCHGE,PYCOMP
36705 C...Parameter statement to help give large particle numbers.
36706       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36707      &KEXCIT=4000000,KDIMEN=5000000)
36708 C...Commonblocks
36709       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36710       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36711       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36712       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36713       COMMON/PYINT1/MINT(400),VINT(400)
36714       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36715       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36716       COMMON/PYINT4/MWID(500),WIDS(500,5)
36717       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36718       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36719      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36720      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36721      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36722       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36723      &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36724 C...Local arrays and complex variables
36725       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36726       COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36727       COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36728       COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36729       COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36730       COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36731       COMPLEX*16 DVVS,DVVT,DVVU
36732       INTEGER INDX(6)
36733  
36734 C...Combinations of weak mixing angle.
36735       TANW=SQRT(XW/XW1)
36736       CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36737  
36738 C...Convert almost equivalent technicolor processes into
36739 C...a few basic processes, and set distinguishing parameters.
36740       IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36741         SQTV=RTCM(12)**2
36742         SQTA=RTCM(13)**2
36743         SN2W=2D0*SQRT(XW*XW1)
36744         CS2W=1D0-2D0*XW
36745         CT2W=CS2W/SN2W
36746         CSXI=COS(ASIN(RTCM(3)))
36747         CSXIP=COS(ASIN(RTCM(4)))
36748         QUPD=2D0*RTCM(2)-1D0
36749         Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36750         CAB2=0D0
36751         VOGP=0D0
36752         VRGP=0D0
36753         AOGP=0D0
36754         ARGP=0D0
36755         VXGP=0D0
36756         AXGP=0D0
36757         VAGP=0D0
36758         VZGP=0D0
36759         VWGP=0D0
36760 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36761         IF(ISUB.EQ.361) THEN
36762            KFA=24
36763            KFB=24
36764            CAB2=RTCM(3)**4
36765            AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36766            ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36767            VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36768 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36769            AXGP = SQRT(2D0)*AXGP
36770            ARGP = SQRT(2D0)*ARGP
36771            VOGP = SQRT(2D0)*VOGP
36772 C... rho_tc0 -> W_L pi_tc-
36773         ELSEIF(ISUB.EQ.362) THEN
36774            KFA=24
36775            KFB=KTECHN+211
36776            ISUB=361
36777            CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36778 C... pi_tc pi_tc
36779         ELSEIF(ISUB.EQ.363) THEN
36780            KFA=KTECHN+211
36781            KFB=KTECHN+211
36782            ISUB=361
36783            CAB2=(1D0-RTCM(3)**2)**2
36784 C... rho_tc0/omega_tc -> gamma pi_tc
36785         ELSEIF(ISUB.EQ.364) THEN
36786            KFA=22
36787            KFB=KTECHN+111
36788            ISUB=361
36789            VOGP=CSXI/RTCM(12)
36790            VRGP=VOGP*QUPD
36791            VAGP=2D0*QUPD*CSXI
36792            VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36793 C... gamma pi_tc'
36794         ELSEIF(ISUB.EQ.365) THEN
36795            KFA=22
36796            KFB=KTECHN+221
36797            ISUB=361
36798            VRGP=CSXIP/RTCM(12)
36799            VOGP=VRGP*QUPD
36800            VAGP=2D0*Q2UD*CSXIP
36801            VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36802 C... Z pi_tc
36803         ELSEIF(ISUB.EQ.366) THEN
36804            KFA=23
36805            KFB=KTECHN+111
36806            ISUB=361
36807            VOGP=CSXI*CT2W/RTCM(12)
36808            VRGP=-QUPD*CSXI*TANW/RTCM(12)
36809            VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36810            VZGP=-QUPD*CSXI*CS2W/XW1
36811 C... Z pi_tc'
36812         ELSEIF(ISUB.EQ.367) THEN
36813            KFA=23
36814            KFB=KTECHN+221
36815            ISUB=361
36816 C...RTCM(48) is the M_V for the techni-a
36817            VXGP=-CSXIP/SN2W/RTCM(48)
36818            VRGP=CSXIP*CT2W/RTCM(12)
36819            VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36820            VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36821            VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36822 C... W_T pi_tc
36823         ELSEIF(ISUB.EQ.368) THEN
36824            KFA=24
36825            KFB=KTECHN+211
36826            ISUB=361
36827 C...RTCM(49) is the M_A for the techni-a
36828            AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36829            VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36830            ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36831            VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36832            VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36833 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36834         ELSEIF(ISUB.EQ.370) THEN
36835            KFA=24
36836            KFB=23
36837            CAB2=RTCM(3)**4
36838            ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36839            AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36840 C... W_L pi_tc0
36841         ELSEIF(ISUB.EQ.371) THEN
36842            KFA=24
36843            KFB=KTECHN+111
36844            ISUB=370
36845            CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36846 C... Z_L pi_tc+
36847         ELSEIF(ISUB.EQ.372) THEN
36848            KFA=KTECHN+211
36849            KFB=23
36850            ISUB=370
36851            CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36852 C... pi_tc+ pi_tc0
36853         ELSEIF(ISUB.EQ.373) THEN
36854            KFA=KTECHN+211
36855            KFB=KTECHN+111
36856            ISUB=370
36857            CAB2=(1D0-RTCM(3)**2)**2
36858 C... gamma pi_tc+
36859         ELSEIF(ISUB.EQ.374) THEN
36860            KFA=KTECHN+211
36861            KFB=22
36862            ISUB=370
36863            VRGP=QUPD*CSXI/RTCM(12)
36864            VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36865            AXGP=-CSXI/RTCM(49)
36866 C... Z_T pi_tc+
36867         ELSEIF(ISUB.EQ.375) THEN
36868            KFA=KTECHN+211
36869            KFB=23
36870            ISUB=370
36871            VRGP=-QUPD*CSXI*TANW/RTCM(12)
36872            ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36873            VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36874            AXGP=-CSXI*CT2W/RTCM(49)
36875 C... W_T pi_tc0
36876         ELSEIF(ISUB.EQ.376) THEN
36877            KFA=24
36878            KFB=KTECHN+111
36879            ISUB=370
36880            VRGP=0D0
36881            ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36882            AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36883 C... W_T pi_tc0'
36884         ELSEIF(ISUB.EQ.377) THEN
36885            KFA=24
36886            KFB=KTECHN+221
36887            ISUB=370
36888            VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36889            VWGP=CSXIP/(2D0*XW)
36890            VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36891 C... gamma W+
36892         ELSEIF(ISUB.EQ.378) THEN
36893            KFA=24
36894            KFB=22
36895            ISUB=370
36896            VRGP=QUPD*RTCM(3)/RTCM(12)
36897            AXGP=-RTCM(3)/RTCM(49)
36898 C... gamma Z
36899         ELSEIF(ISUB.EQ.379) THEN
36900            KFA=23
36901            KFB=22
36902            ISUB=361
36903            VOGP=RTCM(3)/RTCM(12)
36904            VRGP=QUPD*RTCM(3)/RTCM(12)
36905         ELSEIF(ISUB.EQ.380) THEN
36906            KFA=23
36907            KFB=23
36908            ISUB=361
36909            VOGP=RTCM(3)*CT2W/RTCM(12)
36910            VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36911         ENDIF
36912       ENDIF
36913  
36914 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36915       IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36916         IF(ITCM(5).LE.4) THEN
36917           SQDQQS=1D0/SH2
36918           SQDQQT=1D0/TH2
36919           SQDQQU=1D0/UH2
36920           SQDGGS=SQDQQS
36921           SQDGGT=SQDQQT
36922           SQDGGU=SQDQQU
36923           REDGGS=1D0/SH
36924           REDGGT=1D0/TH
36925           REDGGU=1D0/UH
36926           REDGTU=1D0/UH/TH
36927           REDGSU=1D0/SH/UH
36928           REDGST=1D0/SH/TH
36929           REDQST=1D0/SH/TH
36930           REDQTU=1D0/UH/TH
36931           SQDLGS=0D0
36932           SQDLGT=0D0
36933           SQDQTS=SQDQQS
36934         ELSEIF(ITCM(5).EQ.5) THEN
36935           TANT3=RTCM(21)
36936           IF(ITCM(2).EQ.0) THEN
36937             IMDL=1
36938           ELSE
36939             IMDL=2
36940           ENDIF
36941           ALPRHT=2.16D0*(3D0/ITCM(1))
36942           SIN2T=2D0*TANT3/(TANT3**2+1D0)
36943           SINT3=TANT3/SQRT(TANT3**2+1D0)
36944           XIG=SQRT(PYALPS(SH)/ALPRHT)
36945           X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36946      &    RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36947           X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36948      &    RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36949           X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36950      &    SINT3**2)*2D0/SIN2T
36951           X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36952      &    SINT3**2)*2D0/SIN2T
36953  
36954           SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36955           SM1112=X12*RTCM(28)**2*SIN2T
36956           SM1121=-X21*RTCM(28)**2*SIN2T
36957           SM2212=-SM1112
36958           SM2221=-SM1121
36959           SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36960      &    (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36961  
36962 C.........SH LOOP
36963           ZTC(1,1)=DCMPLX(SH,0D0)
36964           CALL PYWIDT(3100021,SH,WDTP,WDTE)
36965           IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36966           ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36967           CALL PYWIDT(3100113,SH,WDTP,WDTE)
36968           ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36969           CALL PYWIDT(3400113,SH,WDTP,WDTE)
36970           ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36971           CALL PYWIDT(3200113,SH,WDTP,WDTE)
36972           ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36973           CALL PYWIDT(3300113,SH,WDTP,WDTE)
36974           ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36975           ZTC(1,2)=(0D0,0D0)
36976           ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36977           ZTC(1,4)=ZTC(1,3)
36978           ZTC(1,5)=ZTC(1,2)
36979           ZTC(1,6)=ZTC(1,2)
36980           ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36981           ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36982           ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36983           ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36984           ZTC(3,4)=-SM1122
36985           ZTC(3,5)=-SM1112
36986           ZTC(3,6)=-SM1121
36987           ZTC(4,5)=-SM2212
36988           ZTC(4,6)=-SM2221
36989           ZTC(5,6)=-SM1221
36990  
36991           DO 110 I=1,5
36992             DO 100 J=I+1,6
36993                ZTC(J,I)=ZTC(I,J)
36994   100       CONTINUE
36995   110     CONTINUE
36996           CALL PYLDCM(ZTC,6,6,INDX,D)
36997           DO 130 I=1,6
36998             DO 120 J=1,6
36999              YTC(I,J)=(0D0,0D0)
37000               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37001   120       CONTINUE
37002   130     CONTINUE
37003  
37004           DO 140 I=1,6
37005             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37006   140     CONTINUE
37007           DGGS=YTC(1,1)
37008           DVVS=YTC(2,2)
37009           DGVS=YTC(1,2)
37010  
37011           XIG=SQRT(PYALPS(-TH)/ALPRHT)
37012 C.........TH LOOP
37013           ZTC(1,1)=DCMPLX(TH)
37014           ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
37015           ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
37016           ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
37017           ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
37018           ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
37019           ZTC(1,2)=(0D0,0D0)
37020           ZTC(1,3)=DCMPLX(TH*XIG,0D0)
37021           ZTC(1,4)=ZTC(1,3)
37022           ZTC(1,5)=ZTC(1,2)
37023           ZTC(1,6)=ZTC(1,2)
37024           ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
37025           ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
37026           ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
37027           ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
37028           ZTC(3,4)=-SM1122
37029           ZTC(3,5)=-SM1112
37030           ZTC(3,6)=-SM1121
37031           ZTC(4,5)=-SM2212
37032           ZTC(4,6)=-SM2221
37033           ZTC(5,6)=-SM1221
37034           DO 160 I=1,5
37035             DO 150 J=I+1,6
37036                ZTC(J,I)=ZTC(I,J)
37037   150       CONTINUE
37038   160     CONTINUE
37039           CALL PYLDCM(ZTC,6,6,INDX,D)
37040           DO 180 I=1,6
37041             DO 170 J=1,6
37042               YTC(I,J)=(0D0,0D0)
37043               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37044   170       CONTINUE
37045   180     CONTINUE
37046           DO 190 I=1,6
37047             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37048   190     CONTINUE
37049           DGGT=YTC(1,1)
37050           DVVT=YTC(2,2)
37051           DGVT=YTC(1,2)
37052  
37053           XIG=SQRT(PYALPS(-UH)/ALPRHT)
37054 C.........UH LOOP
37055           ZTC(1,1)=DCMPLX(UH,0D0)
37056           ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
37057           ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
37058           ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
37059           ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
37060           ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
37061           ZTC(1,2)=(0D0,0D0)
37062           ZTC(1,3)=DCMPLX(UH*XIG,0D0)
37063           ZTC(1,4)=ZTC(1,3)
37064           ZTC(1,5)=ZTC(1,2)
37065           ZTC(1,6)=ZTC(1,2)
37066           ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
37067           ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
37068           ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
37069           ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
37070           ZTC(3,4)=-SM1122
37071           ZTC(3,5)=-SM1112
37072           ZTC(3,6)=-SM1121
37073           ZTC(4,5)=-SM2212
37074           ZTC(4,6)=-SM2221
37075           ZTC(5,6)=-SM1221
37076           DO 210 I=1,5
37077             DO 200 J=I+1,6
37078                ZTC(J,I)=ZTC(I,J)
37079   200       CONTINUE
37080   210     CONTINUE
37081           CALL PYLDCM(ZTC,6,6,INDX,D)
37082           DO 230 I=1,6
37083             DO 220 J=1,6
37084               YTC(I,J)=(0D0,0D0)
37085               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37086   220       CONTINUE
37087   230     CONTINUE
37088           DO 240 I=1,6
37089             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37090   240     CONTINUE
37091           DGGU=YTC(1,1)
37092           DVVU=YTC(2,2)
37093           DGVU=YTC(1,2)
37094  
37095           IF(IMDL.EQ.1) THEN
37096             DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
37097             DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
37098             DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
37099             DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
37100             DQGS=DGGS-DGVS*DCMPLX(TANT3)
37101             DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37102           ELSE
37103             DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37104             DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
37105             DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
37106             DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37107             DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37108             DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37109           ENDIF
37110  
37111           SQDQTS=ABS(DQTS)**2
37112           SQDQQS=ABS(DQQS)**2
37113           SQDQQT=ABS(DQQT)**2
37114           SQDQQU=ABS(DQQU)**2
37115           SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
37116           REDLGS=DBLE(DQGS)
37117           SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
37118           REDHGS=DBLE(DTGS)
37119           SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
37120  
37121           SQDGGS=ABS(DGGS)**2
37122           SQDGGT=ABS(DGGT)**2
37123           SQDGGU=ABS(DGGU)**2
37124           REDGGS=DBLE(DGGS)
37125           REDGGT=DBLE(DGGT)
37126           REDGGU=DBLE(DGGU)
37127           REDGTU=DBLE(DGGU*DCONJG(DGGT))
37128           REDGSU=DBLE(DGGU*DCONJG(DGGS))
37129           REDGST=DBLE(DGGS*DCONJG(DGGT))
37130           REDQST=DBLE(DQQS*DCONJG(DQQT))
37131           REDQTU=DBLE(DQQT*DCONJG(DQQU))
37132         ENDIF
37133       ENDIF
37134  
37135  
37136 C...Differential cross section expressions.
37137  
37138       IF(ISUB.LE.190) THEN
37139         IF(ISUB.EQ.149) THEN
37140 C...g + g -> eta_tc
37141           KCTC=PYCOMP(KTECHN+331)
37142           CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
37143           HS=SHR*WDTP(0)
37144           FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
37145           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37146           HP=SH
37147           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
37148           HI=HP*WDTP(3)
37149           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37150           NCHN=NCHN+1
37151           ISIG(NCHN,1)=21
37152           ISIG(NCHN,2)=21
37153           ISIG(NCHN,3)=1
37154           SIGH(NCHN)=HI*FACBW*HF
37155   250     CONTINUE
37156  
37157         ELSEIF(ISUB.EQ.165) THEN
37158 C...q + qbar -> l+ + l- (including contact term for compositeness)
37159           ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37160           ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37161           KFF=IABS(KFPR(ISUB,1))
37162           EF=KCHG(KFF,1)/3D0
37163           AF=SIGN(1D0,EF+0.1D0)
37164           VF=AF-4D0*EF*XWV
37165           VALF=VF+AF
37166           VARF=VF-AF
37167           FCOF=1D0
37168           IF(KFF.LE.10) FCOF=3D0
37169           WID2=1D0
37170           IF(KFF.EQ.6) WID2=WIDS(6,1)
37171           IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
37172           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37173           DO 260 I=MMINA,MMAXA
37174             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
37175             EI=KCHG(IABS(I),1)/3D0
37176             AI=SIGN(1D0,EI+0.1D0)
37177             VI=AI-4D0*EI*XWV
37178             VALI=VI+AI
37179             VARI=VI-AI
37180             FCOI=1D0
37181             IF(IABS(I).LE.10) FCOI=FACA/3D0
37182             IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
37183               FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
37184      &        (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
37185      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37186             ELSE
37187               FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
37188      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37189             ENDIF
37190             FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
37191      &      (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
37192             FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
37193             IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
37194      &      MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
37195             NCHN=NCHN+1
37196             ISIG(NCHN,1)=I
37197             ISIG(NCHN,2)=-I
37198             ISIG(NCHN,3)=1
37199             SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
37200   260     CONTINUE
37201  
37202         ELSEIF(ISUB.EQ.166) THEN
37203 C...q + q'bar -> l + nu_l (including contact term for compositeness)
37204           WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
37205           WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
37206           KFF=IABS(KFPR(ISUB,1))
37207           FCOF=1D0
37208           IF(KFF.LE.10) FCOF=3D0
37209           DO 280 I=MMIN1,MMAX1
37210             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
37211             IA=IABS(I)
37212             DO 270 J=MMIN2,MMAX2
37213               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
37214               JA=IABS(J)
37215               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
37216               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37217      &        GOTO 270
37218               FCOI=1D0
37219               IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37220               WID2=1D0
37221               IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
37222      &        MOD(J,2).EQ.0)) THEN
37223                 IF(KFF.EQ.5) WID2=WIDS(6,2)
37224                 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
37225                 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
37226               ELSE
37227                 IF(KFF.EQ.5) WID2=WIDS(6,3)
37228                 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
37229                 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
37230               ENDIF
37231               NCHN=NCHN+1
37232               ISIG(NCHN,1)=I
37233               ISIG(NCHN,2)=J
37234               ISIG(NCHN,3)=1
37235               SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
37236               IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
37237      &        SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
37238   270       CONTINUE
37239   280     CONTINUE
37240         ENDIF
37241  
37242       ELSEIF(ISUB.LE.200) THEN
37243         IF(ISUB.EQ.191) THEN
37244 C...q + qbar -> rho_tc0.
37245           KCTC=PYCOMP(KTECHN+113)
37246           SQMRHT=PMAS(KCTC,1)**2
37247           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37248           HS=SHR*WDTP(0)
37249           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37250           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37251           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37252           ALPRHT=2.16D0*(3D0/ITCM(1))
37253           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
37254           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
37255           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37256           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37257           DO 290 I=MMINA,MMAXA
37258             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
37259             IA=IABS(I)
37260             EI=KCHG(IABS(I),1)/3D0
37261             AI=SIGN(1D0,EI+0.1D0)
37262             VI=AI-4D0*EI*XWV
37263             VALI=0.5D0*(VI+AI)
37264             VARI=0.5D0*(VI-AI)
37265             HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
37266      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
37267             IF(IA.LE.10) HI=HI*FACA/3D0
37268             NCHN=NCHN+1
37269             ISIG(NCHN,1)=I
37270             ISIG(NCHN,2)=-I
37271             ISIG(NCHN,3)=1
37272             SIGH(NCHN)=HI*FACBW*HF
37273   290     CONTINUE
37274  
37275         ELSEIF(ISUB.EQ.192) THEN
37276 C...q + qbar' -> rho_tc+/-.
37277           KCTC=PYCOMP(KTECHN+213)
37278           SQMRHT=PMAS(KCTC,1)**2
37279           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37280           HS=SHR*WDTP(0)
37281           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37282           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37283           ALPRHT=2.16D0*(3D0/ITCM(1))
37284           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
37285      &    (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
37286           DO 310 I=MMIN1,MMAX1
37287             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
37288             IA=IABS(I)
37289             DO 300 J=MMIN2,MMAX2
37290               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
37291               JA=IABS(J)
37292               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
37293               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37294      &        GOTO 300
37295               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37296               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
37297               HI=HP
37298               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37299               NCHN=NCHN+1
37300               ISIG(NCHN,1)=I
37301               ISIG(NCHN,2)=J
37302               ISIG(NCHN,3)=1
37303               SIGH(NCHN)=HI*FACBW*HF
37304   300       CONTINUE
37305   310     CONTINUE
37306  
37307         ELSEIF(ISUB.EQ.193) THEN
37308 C...q + qbar -> omega_tc0.
37309           KCTC=PYCOMP(KTECHN+223)
37310           SQMOMT=PMAS(KCTC,1)**2
37311           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37312           HS=SHR*WDTP(0)
37313           FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
37314           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37315           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37316           ALPRHT=2.16D0*(3D0/ITCM(1))
37317           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
37318      &    (2D0*RTCM(2)-1D0)**2
37319           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37320           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37321           DO 320 I=MMINA,MMAXA
37322             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37323             IA=IABS(I)
37324             EI=KCHG(IABS(I),1)/3D0
37325             AI=SIGN(1D0,EI+0.1D0)
37326             VI=AI-4D0*EI*XWV
37327             VALI=0.5D0*(VI+AI)
37328             VARI=0.5D0*(VI-AI)
37329             HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
37330      &      (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
37331             IF(IA.LE.10) HI=HI*FACA/3D0
37332             NCHN=NCHN+1
37333             ISIG(NCHN,1)=I
37334             ISIG(NCHN,2)=-I
37335             ISIG(NCHN,3)=1
37336             SIGH(NCHN)=HI*FACBW*HF
37337   320     CONTINUE
37338  
37339         ELSEIF(ISUB.EQ.194) THEN
37340 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
37341 C...Default final state is e+e-
37342           KFA=KFPR(ISUBSV,1)
37343           ALPRHT=2.16D0*(3D0/ITCM(1))
37344           HP=AEM**2*COMFAC
37345 
37346           SN2W=2D0*SQRT(XW*XW1)
37347 C          TANW=SQRT(PARU(102)/(1D0-PARU(102)))
37348 C          CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
37349  
37350           QUPD=2D0*RTCM(2)-1D0
37351           FAR=SQRT(AEM/ALPRHT)
37352           FAO=FAR*QUPD
37353           FZR=FAR*CT2W
37354           FZO=-FAO*TANW
37355 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37356           FZX=-FAR/SN2W*RTCM(47)
37357           SFAR=FAR**2
37358           SFAO=FAO**2
37359           SFZR=FZR**2
37360           SFZO=FZO**2
37361           SFZX=FZX**2
37362           CALL PYWIDT(23,SH,WDTP,WDTE)
37363           SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37364           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37365           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37366           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37367           SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37368           CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37369           SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37370 C...Propagator including a_T^0
37371           DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37372      $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37373 C...Add in techni-a contribution
37374           DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37375           DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37376      $     SFZX*SSMR*SSMO)/DETD/SH
37377           DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37378           DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37379  
37380           XWRHT=1D0/(4D0*XW*(1D0-XW))
37381           KFF=IABS(KFPR(ISUB,1))
37382           EF=KCHG(KFF,1)/3D0
37383           AF=SIGN(1D0,EF+0.1D0)
37384           VF=AF-4D0*EF*XWV
37385           VALF=0.5D0*(VF+AF)
37386           VARF=0.5D0*(VF-AF)
37387           FCOF=1D0
37388           IF(KFF.LE.10) FCOF=3D0
37389  
37390           WID2=1D0
37391           IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
37392           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37393           DZZ=DZZ*DCMPLX(XWRHT,0D0)
37394           DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
37395  
37396           DO 330 I=MMINA,MMAXA
37397             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
37398             EI=KCHG(IABS(I),1)/3D0
37399             AI=SIGN(1D0,EI+0.1D0)
37400             VI=AI-4D0*EI*XWV
37401             VALI=0.5D0*(VI+AI)
37402             VARI=0.5D0*(VI-AI)
37403             FCOI=FCOF
37404             IF(IABS(I).LE.10) FCOI=FCOI/3D0
37405             DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
37406             DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
37407             DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
37408             DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
37409             FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
37410      &      (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
37411             NCHN=NCHN+1
37412             ISIG(NCHN,1)=I
37413             ISIG(NCHN,2)=-I
37414             ISIG(NCHN,3)=1
37415             SIGH(NCHN)=HP*FCOI*FACSIG*WID2
37416   330     CONTINUE
37417  
37418         ELSEIF(ISUB.EQ.195) THEN
37419 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
37420           KFA=KFPR(ISUBSV,1)
37421           KFB=KFA+1
37422           ALPRHT=2.16D0*(3D0/ITCM(1))
37423           FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
37424  
37425           FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37426 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37427 C
37428 C...Propagator including a_T^+
37429           FWX=-FWR*RTCM(47)
37430           CALL PYWIDT(24,SH,WDTP,WDTE)
37431           SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37432           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37433           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37434           CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37435           SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37436           DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37437      &     DCMPLX(FWX**2,0D0)*SSMR
37438           DWW=SSMR*SSMX/DETD/SH
37439           FCOF=1D0
37440           IF(KFA.LE.8) FCOF=3D0
37441           HP=FACTC*ABS(DWW)**2*FCOF
37442  
37443           DO 350 I=MMIN1,MMAX1
37444             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
37445             IA=IABS(I)
37446             DO 340 J=MMIN2,MMAX2
37447               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
37448               JA=IABS(J)
37449               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
37450               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37451      &        GOTO 340
37452               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37453               HI=HP
37454               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37455               NCHN=NCHN+1
37456               ISIG(NCHN,1)=I
37457               ISIG(NCHN,2)=J
37458               ISIG(NCHN,3)=1
37459               SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
37460   340       CONTINUE
37461   350     CONTINUE
37462         ENDIF
37463  
37464       ELSEIF(ISUB.LE.380) THEN
37465         ALPRHT=2.16D0*(3D0/ITCM(1))
37466         IF(ISUB.EQ.361) THEN
37467           FAR=SQRT(AEM/ALPRHT)
37468           FAO=FAR*QUPD
37469           FZR=FAR*CT2W
37470           FZO=-FAO*TANW
37471 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37472           FZX=-FAR/SN2W*RTCM(47)
37473           SFAR=FAR**2
37474           SFAO=FAO**2
37475           SFZR=FZR**2
37476           SFZO=FZO**2
37477           SFZX=FZX**2
37478           CALL PYWIDT(23,SH,WDTP,WDTE)
37479           SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37480           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37481           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37482           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37483           SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37484           CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37485           SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37486           DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37487      $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37488 C...Add in techni-a contribution
37489           DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37490           DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
37491      $     SFZX*FAR*SSMO)/DETD/SH
37492           DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
37493           DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
37494      $     SFZX*FAO*SSMR)/DETD/SH
37495           DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
37496           DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
37497           DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
37498           DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37499      $     SFZX*SSMR*SSMO)/DETD/SH
37500           DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37501           DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37502  
37503 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
37504 C...W+W-, W pi_tc, pi_T pi_T, etc.
37505           FACA=(SH**2*BE34**2-(TH-UH)**2)
37506           VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37507           AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37508           FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37509           HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH 
37510           DO 370 I=MMINA,MMAXA
37511             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
37512             IA=IABS(I)
37513             EI=KCHG(IABS(I),1)/3D0
37514             AI=SIGN(1D0,EI+0.1D0)
37515             VI=AI-4D0*EI*XWV
37516             VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
37517             VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
37518 C...........Eqs. (5) and (6) in LSTC-rates.pdf
37519             F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
37520             F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
37521             F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
37522             F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
37523      $                    VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
37524             F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
37525             F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
37526             F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
37527             F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
37528      $                    VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
37529             HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
37530 C...........Eqs. (5) and (7) in LSTC-rates.pdf
37531             F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
37532             F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
37533             F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
37534             F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
37535             F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
37536             F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
37537             HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
37538 C
37539 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
37540 C
37541 c$$$            F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37542 c$$$     $      VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37543 c$$$            F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37544 c$$$     $      VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37545             F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37546             F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37547             HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
37548             HI=HI+HJ+HK
37549             IF(IA.LE.10) HI=HI/3D0
37550             NCHN=NCHN+1
37551             ISIG(NCHN,1)=I
37552             ISIG(NCHN,2)=-I
37553             ISIG(NCHN,3)=1
37554             IF(KFA.EQ.KFB) THEN
37555                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
37556             ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
37557                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
37558                NCHN=NCHN+1
37559                ISIG(NCHN,1)=I
37560                ISIG(NCHN,2)=-I
37561                ISIG(NCHN,3)=2
37562                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
37563             ELSE 
37564                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
37565             ENDIF
37566   370     CONTINUE
37567  
37568         ELSEIF(ISUB.EQ.370) THEN
37569 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
37570 C...f + fbar' -> gamma pi_tc, etc.
37571           FACA=(SH**2*BE34**2-(TH-UH)**2)
37572           FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37573           VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37574           AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37575           ALPRHT=2.16D0*(3D0/ITCM(1))
37576           FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
37577           FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37578 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37579           FWX=-FWR*RTCM(47)
37580           CALL PYWIDT(24,SH,WDTP,WDTE)
37581           SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37582           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37583           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37584           CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37585           SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37586           DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37587      &     DCMPLX(FWX**2,0D0)*SSMR
37588           DWW=SSMR*SSMX/DETD/SH
37589           DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
37590           DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
37591           HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
37592      $    VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
37593 C
37594 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
37595 C
37596 c$$$          HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
37597           HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
37598 C...Add in W_L Z_T axial and vector contributions.
37599           IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
37600      $    (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)*     !AFAC w/ switched masses.
37601      $    ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
37602      $    VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
37603           DO 410 I=MMIN1,MMAX1
37604             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
37605             IA=IABS(I)
37606             DO 400 J=MMIN2,MMAX2
37607               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
37608               JA=IABS(J)
37609               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
37610               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37611      &        GOTO 400
37612               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37613               HI=HP
37614               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37615               NCHN=NCHN+1
37616               ISIG(NCHN,1)=I
37617               ISIG(NCHN,2)=J
37618               ISIG(NCHN,3)=1
37619               IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
37620                 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
37621               ELSE
37622                 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
37623      &          WIDS(PYCOMP(KFB),2)
37624               ENDIF
37625   400       CONTINUE
37626   410     CONTINUE
37627         ENDIF
37628  
37629       ELSEIF(ISUB.LE.390) THEN
37630         IF(ISUB.EQ.381) THEN
37631 C...f + f' -> f + f' (g exchange)
37632           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
37633           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
37634      &    MSTP(34)*2D0/3D0*UH2*REDQST)
37635           FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
37636           FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
37637           RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
37638           IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
37639 C...Modifications from contact interactions (compositeness)
37640             FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
37641             FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37642      &      (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
37643             FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37644      &      (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
37645             FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
37646             RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
37647           ELSEIF(ITCM(5).EQ.5) THEN
37648             FACCI1=FACQQ1
37649             FACCIB=FACQQB
37650             FACCI2=FACQQ2
37651             FACCI3=FACQQ1
37652 CSM.......Check this change from
37653 CSM            RATCII=1D0
37654             RATCII=RATQQI
37655           ENDIF
37656           DO 430 I=MMIN1,MMAX1
37657             IA=IABS(I)
37658             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
37659             DO 420 J=MMIN2,MMAX2
37660               JA=IABS(J)
37661               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37662               NCHN=NCHN+1
37663               ISIG(NCHN,1)=I
37664               ISIG(NCHN,2)=J
37665               ISIG(NCHN,3)=1
37666               IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37667      &        JA.GE.3))) THEN
37668                 SIGH(NCHN)=FACQQ1
37669                 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37670               ELSE
37671                 SIGH(NCHN)=FACCI1
37672                 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37673                 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37674               ENDIF
37675               IF(I.EQ.J) THEN
37676                 NCHN=NCHN+1
37677                 ISIG(NCHN,1)=I
37678                 ISIG(NCHN,2)=J
37679                 ISIG(NCHN,3)=2
37680                 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37681                   SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37682                   SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37683                 ELSE
37684                   SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37685                   SIGH(NCHN)=0.5D0*FACCI2*RATCII
37686                 ENDIF
37687               ENDIF
37688   420       CONTINUE
37689   430     CONTINUE
37690  
37691         ELSEIF(ISUB.EQ.382) THEN
37692 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37693           CALL PYWIDT(21,SH,WDTP,WDTE)
37694           FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37695           FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37696           IF(ITCM(5).EQ.1) THEN
37697 C...Modifications from contact interactions (compositeness)
37698             FACCIB=FACQQB
37699             DO 440 I=1,2
37700               FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37701      &        WDTE(I,2)+WDTE(I,4))
37702   440       CONTINUE
37703           ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37704             FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37705      &      (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37706           ELSEIF(ITCM(5).EQ.5) THEN
37707             FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37708      &      WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37709             FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37710           ENDIF
37711           DO 450 I=MMINA,MMAXA
37712             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37713      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37714             NCHN=NCHN+1
37715             ISIG(NCHN,1)=I
37716             ISIG(NCHN,2)=-I
37717             ISIG(NCHN,3)=1
37718             IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37719               SIGH(NCHN)=FACQQB
37720             ELSEIF(ITCM(5).EQ.5) THEN
37721               SIGH(NCHN)=FACQQB
37722               NCHN=NCHN+1
37723               ISIG(NCHN,1)=I
37724               ISIG(NCHN,2)=-I
37725               ISIG(NCHN,3)=2
37726               SIGH(NCHN)=FACCIB
37727             ELSE
37728               SIGH(NCHN)=FACCIB
37729             ENDIF
37730   450     CONTINUE
37731  
37732         ELSEIF(ISUB.EQ.383) THEN
37733 C...f + fbar -> g + g (q + qbar -> g + g only)
37734           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37735      &    UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37736           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37737      &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37738           IF(ITCM(5).EQ.5) THEN
37739             FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37740      &      UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37741             FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37742      &      TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37743           ENDIF
37744           DO 460 I=MMINA,MMAXA
37745             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37746      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37747             NCHN=NCHN+1
37748             ISIG(NCHN,1)=I
37749             ISIG(NCHN,2)=-I
37750             ISIG(NCHN,3)=1
37751             SIGH(NCHN)=0.5D0*FACGG1
37752             IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37753             NCHN=NCHN+1
37754             ISIG(NCHN,1)=I
37755             ISIG(NCHN,2)=-I
37756             ISIG(NCHN,3)=2
37757             SIGH(NCHN)=0.5D0*FACGG2
37758             IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37759   460     CONTINUE
37760  
37761         ELSEIF(ISUB.EQ.384) THEN
37762 C...f + g -> f + g (q + g -> q + g only)
37763           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37764      &    UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37765           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37766      &    SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37767           DO 480 I=MMINA,MMAXA
37768             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37769             DO 470 ISDE=1,2
37770               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37771               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37772               NCHN=NCHN+1
37773               ISIG(NCHN,ISDE)=I
37774               ISIG(NCHN,3-ISDE)=21
37775               ISIG(NCHN,3)=1
37776               SIGH(NCHN)=FACQG1
37777               NCHN=NCHN+1
37778               ISIG(NCHN,ISDE)=I
37779               ISIG(NCHN,3-ISDE)=21
37780               ISIG(NCHN,3)=2
37781               SIGH(NCHN)=FACQG2
37782   470       CONTINUE
37783   480     CONTINUE
37784  
37785         ELSEIF(ISUB.EQ.385) THEN
37786 C...g + g -> f + fbar (g + g -> q + qbar only)
37787           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37788           IDC0=MDCY(21,2)-1
37789 C...Begin by d, u, s flavours.
37790           FLAVWT=0D0
37791           IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37792      &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37793           IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37794      &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37795           IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37796      &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37797           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37798      &    UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37799           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37800      &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37801           NCHN=NCHN+1
37802           ISIG(NCHN,1)=21
37803           ISIG(NCHN,2)=21
37804           ISIG(NCHN,3)=1
37805           SIGH(NCHN)=FACQQ1
37806           NCHN=NCHN+1
37807           ISIG(NCHN,1)=21
37808           ISIG(NCHN,2)=21
37809           ISIG(NCHN,3)=2
37810           SIGH(NCHN)=FACQQ2
37811 C...Next c and b flavours: modified that and uhat for fixed
37812 C...cos(theta-hat).
37813           DO 490 IFL=4,5
37814           SQMAVG=PMAS(IFL,1)**2
37815           IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37816             BE34=SQRT(1D0-4D0*SQMAVG/SH)
37817             THQ=-0.5D0*SH*(1D0-BE34*CTH)
37818             UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37819             THUHQ=THQ*UHQ-SQMAVG*SH
37820             IF(MSTP(34).EQ.0) THEN
37821               FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37822               FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37823             ELSE
37824               FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37825      &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37826               FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37827      &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37828             ENDIF
37829             IF(ITCM(5).GE.5) THEN
37830               IF(IFL.EQ.4) THEN
37831                 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37832      &          2.25D0*THQ*UHQ/SH2*SQDLGS
37833                 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37834      &          2.25D0*THQ*UHQ/SH2*SQDLGS
37835               ELSE
37836                 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37837      &          2.25D0*THQ*UHQ/SH2*SQDHGS
37838                 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37839      &          2.25D0*THQ*UHQ/SH2*SQDHGS
37840               ENDIF
37841             ENDIF
37842             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37843             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37844             NCHN=NCHN+1
37845             ISIG(NCHN,1)=21
37846             ISIG(NCHN,2)=21
37847             ISIG(NCHN,3)=1+2*(IFL-3)
37848             SIGH(NCHN)=FACQQ1
37849             NCHN=NCHN+1
37850             ISIG(NCHN,1)=21
37851             ISIG(NCHN,2)=21
37852             ISIG(NCHN,3)=2+2*(IFL-3)
37853             SIGH(NCHN)=FACQQ2
37854           ENDIF
37855   490     CONTINUE
37856   500     CONTINUE
37857  
37858         ELSEIF(ISUB.EQ.386) THEN
37859 C...g + g -> g + g
37860           IF(ITCM(5).LE.4) THEN
37861             FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37862      &      2D0*TH/SH+TH2/SH2)*FACA
37863             FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37864      &      2D0*SH/UH+SH2/UH2)*FACA
37865             FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37866      &      2D0*UH/TH+UH2/TH2)
37867           ELSE
37868             GST=  (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37869      &      16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37870      &      4D0*REDGST*(SH + 2D0*TH)*
37871      &      (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37872      &      2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37873      &      2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37874      &      32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37875      &      SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37876      &      96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37877             GSU=  (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37878      &      16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37879      &      4D0*REDGSU*(SH + 2D0*UH)*
37880      &      (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37881      &      2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37882      &      2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37883      &      32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37884      &      SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37885      &      96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37886             GUT=  (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37887      &      4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37888      &      58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37889      &      4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37890      &      48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37891      &      4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37892      &      72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37893      &      4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37894      &      72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37895      &      2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37896      &      30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37897      &      SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37898      &      52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37899             FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37900             FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37901             FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37902           ENDIF
37903           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37904           NCHN=NCHN+1
37905           ISIG(NCHN,1)=21
37906           ISIG(NCHN,2)=21
37907           ISIG(NCHN,3)=1
37908           SIGH(NCHN)=0.5D0*FACGG1
37909           NCHN=NCHN+1
37910           ISIG(NCHN,1)=21
37911           ISIG(NCHN,2)=21
37912           ISIG(NCHN,3)=2
37913           SIGH(NCHN)=0.5D0*FACGG2
37914           NCHN=NCHN+1
37915           ISIG(NCHN,1)=21
37916           ISIG(NCHN,2)=21
37917           ISIG(NCHN,3)=3
37918           SIGH(NCHN)=0.5D0*FACGG3
37919   510     CONTINUE
37920  
37921         ELSEIF(ISUB.EQ.387) THEN
37922 C...q + qbar -> Q + Qbar
37923           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37924           THQ=-0.5D0*SH*(1D0-BE34*CTH)
37925           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37926           FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37927      &    2D0*SQMAVG/SH)
37928           IF(ITCM(5).GE.5) THEN
37929             IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37930               FACQQB=FACQQB*SH2*SQDQTS
37931             ELSE
37932               FACQQB=FACQQB*SH2*SQDQQS
37933             ENDIF
37934           ENDIF
37935           IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37936           WID2=1D0
37937           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37938           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37939           FACQQB=FACQQB*WID2
37940           DO 520 I=MMINA,MMAXA
37941             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37942      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37943             NCHN=NCHN+1
37944             ISIG(NCHN,1)=I
37945             ISIG(NCHN,2)=-I
37946             ISIG(NCHN,3)=1
37947             SIGH(NCHN)=FACQQB
37948   520     CONTINUE
37949  
37950         ELSEIF(ISUB.EQ.388) THEN
37951 C...g + g -> Q + Qbar
37952           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37953           THQ=-0.5D0*SH*(1D0-BE34*CTH)
37954           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37955           THUHQ=THQ*UHQ-SQMAVG*SH
37956           IF(MSTP(34).EQ.0) THEN
37957             FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37958             FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37959           ELSE
37960             FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37961      &      THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37962             FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37963      &      UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37964           ENDIF
37965           IF(ITCM(5).GE.5) THEN
37966             IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37967               FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37968      &        2.25D0*THQ*UHQ/SH2*SQDHGS
37969               FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37970      &        2.25D0*THQ*UHQ/SH2*SQDHGS
37971             ELSE
37972               FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37973      &        2.25D0*THQ*UHQ/SH2*SQDLGS
37974               FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37975      &        2.25D0*THQ*UHQ/SH2*SQDLGS
37976             ENDIF
37977           ENDIF
37978           FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37979           FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37980           IF(MSTP(35).GE.1) THEN
37981             FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37982             FACQQ1=FACQQ1*FATRE
37983             FACQQ2=FACQQ2*FATRE
37984           ENDIF
37985           WID2=1D0
37986           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37987           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37988           FACQQ1=FACQQ1*WID2
37989           FACQQ2=FACQQ2*WID2
37990           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37991           NCHN=NCHN+1
37992           ISIG(NCHN,1)=21
37993           ISIG(NCHN,2)=21
37994           ISIG(NCHN,3)=1
37995           SIGH(NCHN)=FACQQ1
37996           NCHN=NCHN+1
37997           ISIG(NCHN,1)=21
37998           ISIG(NCHN,2)=21
37999           ISIG(NCHN,3)=2
38000           SIGH(NCHN)=FACQQ2
38001   530     CONTINUE
38002         ENDIF
38003       ENDIF
38004  
38005 CMRENNA--
38006  
38007       RETURN
38008       END
38009  
38010 C*********************************************************************
38011  
38012 C...PYSGEX
38013 C...Subprocess cross sections for assorted exotic processes,
38014 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
38015 C...Auxiliary to PYSIGH.
38016  
38017       SUBROUTINE PYSGEX(NCHN,SIGS)
38018  
38019 C...Double precision and integer declarations
38020       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38021       IMPLICIT INTEGER(I-N)
38022       INTEGER PYK,PYCHGE,PYCOMP
38023 C...Parameter statement to help give large particle numbers.
38024       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38025      &KEXCIT=4000000,KDIMEN=5000000)
38026 C...Commonblocks
38027       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38028       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38029       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38030       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38031       COMMON/PYINT1/MINT(400),VINT(400)
38032       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38033       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38034       COMMON/PYINT4/MWID(500),WIDS(500,5)
38035       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
38036       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
38037      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
38038      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
38039      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
38040       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
38041      &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
38042 C...Local arrays
38043       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
38044  
38045 C...Differential cross section expressions.
38046  
38047       IF(ISUB.LE.160) THEN
38048         IF(ISUB.EQ.141) THEN
38049 C...f + fbar -> gamma*/Z0/Z'0
38050           SQMZP=PMAS(32,1)**2
38051           MINT(61)=2
38052           CALL PYWIDT(32,SH,WDTP,WDTE)
38053           HP0=AEM/3D0*SH
38054           HP1=AEM/3D0*XWC*SH
38055           HP2=HP1
38056           HS=SHR*VINT(117)
38057           HSP=SHR*WDTP(0)
38058           FACZP=4D0*COMFAC*3D0
38059           DO 100 I=MMINA,MMAXA
38060             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
38061             EI=KCHG(IABS(I),1)/3D0
38062             AI=SIGN(1D0,EI)
38063             VI=AI-4D0*EI*XWV
38064             IA=IABS(I)
38065             IF(IA.LT.10) THEN
38066               IF(IA.LE.2) THEN
38067                 VPI=PARU(123-2*MOD(IABS(I),2))
38068                 API=PARU(124-2*MOD(IABS(I),2))
38069               ELSEIF(IA.LE.4) THEN
38070                 VPI=PARJ(182-2*MOD(IABS(I),2))
38071                 API=PARJ(183-2*MOD(IABS(I),2))
38072               ELSE
38073                 VPI=PARJ(190-2*MOD(IABS(I),2))
38074                 API=PARJ(191-2*MOD(IABS(I),2))
38075               ENDIF
38076             ELSE
38077               IF(IA.LE.12) THEN
38078                 VPI=PARU(127-2*MOD(IABS(I),2))
38079                 API=PARU(128-2*MOD(IABS(I),2))
38080               ELSEIF(IA.LE.14) THEN
38081                 VPI=PARJ(186-2*MOD(IABS(I),2))
38082                 API=PARJ(187-2*MOD(IABS(I),2))
38083               ELSE
38084                 VPI=PARJ(194-2*MOD(IABS(I),2))
38085                 API=PARJ(195-2*MOD(IABS(I),2))
38086               ENDIF
38087             ENDIF
38088             HI0=HP0
38089             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
38090             HI1=HP1
38091             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
38092             HI2=HP2
38093             IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
38094             NCHN=NCHN+1
38095             ISIG(NCHN,1)=I
38096             ISIG(NCHN,2)=-I
38097             ISIG(NCHN,3)=1
38098 C...Special case: if only branching ratios known then use them.
38099             IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
38100               HI=0D0
38101               IF(IA.LT.10) THEN
38102                 HI=SHR*WDTP(IA)*FACA/9D0
38103               ELSEIF(IA.LT.20) THEN
38104                 HI=SHR*WDTP(IA-2)
38105               ENDIF
38106               HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38107               SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
38108             ELSE
38109 C...Normal cross section.
38110               SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
38111      &        (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
38112      &        VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
38113      &        (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
38114      &        ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
38115      &        ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
38116      &        ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
38117      &        (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
38118             ENDIF
38119   100     CONTINUE
38120  
38121         ELSEIF(ISUB.EQ.142) THEN
38122 C...f + fbar' -> W'+/-
38123           SQMWP=PMAS(34,1)**2
38124           CALL PYWIDT(34,SH,WDTP,WDTE)
38125           HS=SHR*WDTP(0)
38126           FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
38127           HP=AEM/(24D0*XW)*SH
38128           DO 120 I=MMIN1,MMAX1
38129             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
38130             IA=IABS(I)
38131             DO 110 J=MMIN2,MMAX2
38132               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
38133               JA=IABS(J)
38134               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
38135               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38136      &        GOTO 110
38137               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38138 C...Special case: if only branching ratios known then use them.
38139               IF(MWID(34).EQ.2) THEN
38140                 HI=0D0
38141                 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
38142                   IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
38143      &            IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
38144      &            .AND.JA.EQ.IABS(KFDP(IDC,1))))
38145      &             HI=SHR*WDTP(IDC+1-MDCY(34,2))
38146   105           CONTINUE
38147                 IF(IA.LT.10) HI=HI*FACA/9D0
38148               ELSE
38149 C...Normal cross section.
38150                 HI=HP*(PARU(133)**2+PARU(134)**2)
38151                 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
38152      &          VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38153               ENDIF 
38154               NCHN=NCHN+1
38155               ISIG(NCHN,1)=I
38156               ISIG(NCHN,2)=J
38157               ISIG(NCHN,3)=1
38158               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38159               SIGH(NCHN)=HI*FACBW*HF
38160   110       CONTINUE
38161   120     CONTINUE
38162  
38163         ELSEIF(ISUB.EQ.144) THEN
38164 C...f + fbar' -> R
38165           SQMR=PMAS(41,1)**2
38166           CALL PYWIDT(41,SH,WDTP,WDTE)
38167           HS=SHR*WDTP(0)
38168           FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
38169           HP=AEM/(12D0*XW)*SH
38170           DO 140 I=MMIN1,MMAX1
38171             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
38172             IA=IABS(I)
38173             DO 130 J=MMIN2,MMAX2
38174               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
38175               JA=IABS(J)
38176               IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
38177               HI=HP
38178               IF(IA.LE.10) HI=HI*FACA/3D0
38179               HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
38180               NCHN=NCHN+1
38181               ISIG(NCHN,1)=I
38182               ISIG(NCHN,2)=J
38183               ISIG(NCHN,3)=1
38184               SIGH(NCHN)=HI*FACBW*HF
38185   130       CONTINUE
38186   140     CONTINUE
38187  
38188         ELSEIF(ISUB.EQ.145) THEN
38189 C...q + l -> LQ (leptoquark)
38190           SQMLQ=PMAS(42,1)**2
38191           CALL PYWIDT(42,SH,WDTP,WDTE)
38192           HS=SHR*WDTP(0)
38193           FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
38194           IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
38195           HP=AEM/4D0*SH
38196           KFLQQ=KFDP(MDCY(42,2),1)
38197           KFLQL=KFDP(MDCY(42,2),2)
38198           DO 160 I=MMIN1,MMAX1
38199             IF(KFAC(1,I).EQ.0) GOTO 160
38200             IA=IABS(I)
38201             IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
38202             DO 150 J=MMIN2,MMAX2
38203               IF(KFAC(2,J).EQ.0) GOTO 150
38204               JA=IABS(J)
38205               IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
38206               IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
38207               IF(JA.EQ.IA) GOTO 150
38208               IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
38209               IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
38210               HI=HP*PARU(151)
38211               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
38212               NCHN=NCHN+1
38213               ISIG(NCHN,1)=I
38214               ISIG(NCHN,2)=J
38215               ISIG(NCHN,3)=1
38216               SIGH(NCHN)=HI*FACBW*HF
38217   150       CONTINUE
38218   160     CONTINUE
38219  
38220         ELSEIF(ISUB.EQ.146) THEN
38221 C...e + gamma* -> e* (excited lepton)
38222           KFQSTR=KFPR(ISUB,1)
38223           KCQSTR=PYCOMP(KFQSTR)
38224           KFQEXC=MOD(KFQSTR,KEXCIT)
38225           CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38226           HS=SHR*WDTP(0)
38227           FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38228           QF=-RTCM(43)/2D0-RTCM(44)/2D0
38229           FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
38230           IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38231      &    FACBW=0D0
38232           HP=SH
38233           DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
38234             DO 170 ISDE=1,2
38235               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
38236               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
38237               HI=HP
38238               IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38239               IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38240               NCHN=NCHN+1
38241               ISIG(NCHN,ISDE)=I
38242               ISIG(NCHN,3-ISDE)=22
38243               ISIG(NCHN,3)=1
38244               SIGH(NCHN)=HI*FACBW*HF
38245   170       CONTINUE
38246   180     CONTINUE
38247  
38248         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
38249 C...d + g -> d* and u + g -> u* (excited quarks)
38250           KFQSTR=KFPR(ISUB,1)
38251           KCQSTR=PYCOMP(KFQSTR)
38252           KFQEXC=MOD(KFQSTR,KEXCIT)
38253           CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38254           HS=SHR*WDTP(0)
38255           FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38256           FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
38257           IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38258      &    FACBW=0D0
38259           HP=SH
38260           DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
38261             DO 190 ISDE=1,2
38262               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
38263               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
38264               HI=HP
38265               IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38266               IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38267               NCHN=NCHN+1
38268               ISIG(NCHN,ISDE)=I
38269               ISIG(NCHN,3-ISDE)=21
38270               ISIG(NCHN,3)=1
38271               SIGH(NCHN)=HI*FACBW*HF
38272   190       CONTINUE
38273   200     CONTINUE
38274         ENDIF
38275  
38276       ELSEIF(ISUB.LE.190) THEN
38277         IF(ISUB.EQ.162) THEN
38278 C...q + g -> LQ + lbar; LQ=leptoquark
38279           SQMLQ=PMAS(42,1)**2
38280           FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
38281      &    (UH2+SQMLQ**2)/(UH-SQMLQ)**2
38282           KFLQQ=KFDP(MDCY(42,2),1)
38283           DO 220 I=MMINA,MMAXA
38284             IF(IABS(I).NE.KFLQQ) GOTO 220
38285             KCHLQ=ISIGN(1,I)
38286             DO 210 ISDE=1,2
38287               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
38288               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
38289               NCHN=NCHN+1
38290               ISIG(NCHN,ISDE)=I
38291               ISIG(NCHN,3-ISDE)=21
38292               ISIG(NCHN,3)=1
38293               SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
38294   210       CONTINUE
38295   220     CONTINUE
38296  
38297         ELSEIF(ISUB.EQ.163) THEN
38298 C...g + g -> LQ + LQbar; LQ=leptoquark
38299           SQMLQ=PMAS(42,1)**2
38300           FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
38301      &    (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
38302      &    (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
38303      &    ((TH-SQMLQ)*(UH-SQMLQ)))
38304           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
38305           NCHN=NCHN+1
38306           ISIG(NCHN,1)=21
38307           ISIG(NCHN,2)=21
38308 C...Since don't know proper colour flow, randomize between alternatives
38309           ISIG(NCHN,3)=INT(1.5D0+PYR(0))
38310           SIGH(NCHN)=FACLQ
38311   230     CONTINUE
38312  
38313         ELSEIF(ISUB.EQ.164) THEN
38314 C...q + qbar -> LQ + LQbar; LQ=leptoquark
38315           DELTA=0.25D0*(SQM3-SQM4)**2/SH
38316           SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
38317           TH=TH-DELTA
38318           UH=UH-DELTA
38319 C          SQMLQ=PMAS(42,1)**2
38320           FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
38321      &    (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
38322           FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
38323      &    (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
38324      &    ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
38325           KFLQQ=KFDP(MDCY(42,2),1)
38326           DO 240 I=MMINA,MMAXA
38327             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38328      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
38329             NCHN=NCHN+1
38330             ISIG(NCHN,1)=I
38331             ISIG(NCHN,2)=-I
38332             ISIG(NCHN,3)=1
38333             SIGH(NCHN)=FACLQA
38334             IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
38335   240     CONTINUE
38336  
38337         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
38338 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
38339           KFQSTR=KFPR(ISUB,2)
38340           KCQSTR=PYCOMP(KFQSTR)
38341           KFQEXC=MOD(KFQSTR,KEXCIT)
38342           FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
38343           FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38344      &    (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38345 C...Propagators: as simulated in PYOFSH and as desired
38346           GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38347           HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38348           CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38349           GMMQC=SQRT(SQM4)*WDTP(0)
38350           HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38351           FACQSA=FACQSA*HBW4C/HBW4
38352           FACQSB=FACQSB*HBW4C/HBW4
38353 C...Branching ratios.
38354           BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38355           BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38356           DO 260 I=MMIN1,MMAX1
38357             IA=IABS(I)
38358             IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
38359             DO 250 J=MMIN2,MMAX2
38360               JA=IABS(J)
38361               IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
38362               IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
38363                 NCHN=NCHN+1
38364                 ISIG(NCHN,1)=I
38365                 ISIG(NCHN,2)=J
38366                 ISIG(NCHN,3)=1
38367                 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38368                 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38369                 NCHN=NCHN+1
38370                 ISIG(NCHN,1)=I
38371                 ISIG(NCHN,2)=J
38372                 ISIG(NCHN,3)=2
38373                 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38374                 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38375               ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
38376                 NCHN=NCHN+1
38377                 ISIG(NCHN,1)=I
38378                 ISIG(NCHN,2)=J
38379                 ISIG(NCHN,3)=1
38380                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38381                 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
38382                 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
38383               ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
38384                 NCHN=NCHN+1
38385                 ISIG(NCHN,1)=I
38386                 ISIG(NCHN,2)=J
38387                 ISIG(NCHN,3)=1
38388                 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38389                 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38390                 NCHN=NCHN+1
38391                 ISIG(NCHN,1)=I
38392                 ISIG(NCHN,2)=J
38393                 ISIG(NCHN,3)=2
38394                 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38395                 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38396               ELSEIF(I.EQ.-J) THEN
38397                 NCHN=NCHN+1
38398                 ISIG(NCHN,1)=I
38399                 ISIG(NCHN,2)=J
38400                 ISIG(NCHN,3)=1
38401                 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38402                 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38403                 NCHN=NCHN+1
38404                 ISIG(NCHN,1)=I
38405                 ISIG(NCHN,2)=J
38406                 ISIG(NCHN,3)=2
38407                 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38408                 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38409               ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
38410                 NCHN=NCHN+1
38411                 ISIG(NCHN,1)=I
38412                 ISIG(NCHN,2)=J
38413                 ISIG(NCHN,3)=1
38414                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38415                 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
38416                 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
38417               ENDIF
38418   250       CONTINUE
38419   260     CONTINUE
38420  
38421         ELSEIF(ISUB.EQ.169) THEN
38422 C...q + qbar -> e + e* (excited lepton)
38423           KFQSTR=KFPR(ISUB,2)
38424           KCQSTR=PYCOMP(KFQSTR)
38425           KFQEXC=MOD(KFQSTR,KEXCIT)
38426           FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38427      &    (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38428 C...Propagators: as simulated in PYOFSH and as desired
38429           GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38430           HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38431           CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38432           GMMQC=SQRT(SQM4)*WDTP(0)
38433           HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38434           FACQSB=FACQSB*HBW4C/HBW4
38435 C...Branching ratios.
38436           BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38437           BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38438           DO 270 I=MMIN1,MMAX1
38439             IA=IABS(I)
38440             IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
38441             J=-I
38442             JA=IABS(J)
38443             IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
38444             NCHN=NCHN+1
38445             ISIG(NCHN,1)=I
38446             ISIG(NCHN,2)=J
38447             ISIG(NCHN,3)=1
38448             IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38449             IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38450             NCHN=NCHN+1
38451             ISIG(NCHN,1)=I
38452             ISIG(NCHN,2)=J
38453             ISIG(NCHN,3)=2
38454             IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38455             IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38456   270     CONTINUE
38457         ENDIF
38458  
38459       ELSEIF(ISUB.LE.360) THEN
38460         IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
38461 C...l + l -> H_L++/-- or H_R++/--.
38462           KFRES=KFPR(ISUB,1)
38463           KFREC=PYCOMP(KFRES)
38464           CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38465           HS=SHR*WDTP(0)
38466           FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
38467           DO 290 I=MMIN1,MMAX1
38468             IA=IABS(I)
38469             IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
38470      &      GOTO 290
38471             DO 280 J=MMIN2,MMAX2
38472               JA=IABS(J)
38473               IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
38474      &        GOTO 280
38475               IF(I*J.LT.0) GOTO 280
38476               KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38477               NCHN=NCHN+1
38478               ISIG(NCHN,1)=I
38479               ISIG(NCHN,2)=J
38480               ISIG(NCHN,3)=1
38481               HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
38482               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38483               SIGH(NCHN)=HI*FACBW*HF
38484   280       CONTINUE
38485   290     CONTINUE
38486  
38487         ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
38488 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
38489           KFRES=KFPR(ISUB,1)
38490           KFREC=PYCOMP(KFRES)
38491 C...Propagators: as simulated in PYOFSH and as desired
38492           HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
38493      &    (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
38494           CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38495           GMMC=SQRT(SQM3)*WDTP(0)
38496           HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
38497           FHCC=COMFAC*AEM*HBW3C/HBW3
38498           DO 310 I=MMINA,MMAXA
38499             IA=IABS(I)
38500             IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
38501             SQML=PMAS(IA,1)**2
38502             J=ISIGN(KFPR(ISUB,2),-I)
38503             KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
38504             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
38505             SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
38506      &      (UH-SQM3)**2
38507             SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
38508      &      (TH-SQM4)*SH)/(TH-SQM4)**2
38509             SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
38510      &      SH)/(SH-SQML)**2
38511             SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
38512      &      3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
38513      &      ((UH-SQM3)*(TH-SQM4))
38514             SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
38515      &      SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
38516      &      ((UH-SQM3)*(SH-SQML))
38517             SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
38518      &      3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
38519      &      ((SH-SQML)*(TH-SQM4))
38520             SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
38521      &      PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
38522             DO 300 ISDE=1,2
38523               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
38524               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
38525               NCHN=NCHN+1
38526               ISIG(NCHN,ISDE)=I
38527               ISIG(NCHN,3-ISDE)=22
38528               ISIG(NCHN,3)=0
38529               SIGH(NCHN)=FHCC*SMM*WIDSC
38530   300       CONTINUE
38531   310     CONTINUE
38532  
38533         ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
38534 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
38535           KFRES=KFPR(ISUB,1)
38536           KFREC=PYCOMP(KFRES)
38537           SQMH=PMAS(KFREC,1)**2
38538           GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
38539 C...Propagators: H++/-- as simulated in PYOFSH and as desired
38540           HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38541           CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38542           GMMH3=SQRT(SQM3)*WDTP(0)
38543           HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38544           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38545           CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
38546           GMMH4=SQRT(SQM4)*WDTP(0)
38547           HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38548 C...Kinematical and coupling functions
38549           FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
38550           XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
38551 C...Loop over allowed flavours
38552           DO 320 I=MMINA,MMAXA
38553             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
38554             EI=KCHG(IABS(I),1)/3D0
38555             AI=SIGN(1D0,EI+0.1D0)
38556             VI=AI-4D0*EI*XWV
38557             FCOI=1D0
38558             IF(IABS(I).LE.10) FCOI=FACA/3D0
38559             IF(ISUB.EQ.349) THEN
38560               HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
38561               IF(IABS(I).LT.10) THEN
38562                 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38563      &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38564      &          (VI**2+AI**2)*XWHH**2*HBWZ)
38565               ELSE
38566                 IAOFF=181+3*((IABS(I)-11)/2)
38567                 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38568      &          (4D0*PARU(1))
38569                 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38570      &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38571      &          (VI**2+AI**2)*XWHH**2*HBWZ)+
38572      &          8D0*AEM*(EI*HSUM/(SH*TH)+
38573      &          (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
38574      &          4D0*HSUM**2/TH2
38575               ENDIF
38576             ELSE
38577               IF(IABS(I).LT.10) THEN
38578                 DSIGHH=8D0*AEM**2*EI**2/SH2
38579               ELSE
38580                 IAOFF=181+3*((IABS(I)-11)/2)
38581                 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38582      &          (4D0*PARU(1))
38583                 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
38584      &          4D0*HSUM**2/TH2
38585               ENDIF
38586             ENDIF
38587             NCHN=NCHN+1
38588             ISIG(NCHN,1)=I
38589             ISIG(NCHN,2)=-I
38590             ISIG(NCHN,3)=1
38591             SIGH(NCHN)=FACHH*FCOI*DSIGHH
38592   320     CONTINUE
38593  
38594         ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
38595 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
38596           KFRES=KFPR(ISUB,1)
38597           KFREC=PYCOMP(KFRES)
38598           SQMH=PMAS(KFREC,1)**2
38599           IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
38600           IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
38601      &    PMAS(PYCOMP(9900024),1)**2
38602           FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
38603           FACPRT=1D0/((VINT(204)**2-VINT(215))*
38604      &    (VINT(209)**2-VINT(216)))
38605           FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
38606      &    (VINT(209)**2+2D0*VINT(218)))
38607           CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38608           HS=SHR*WDTP(0)
38609           FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
38610           IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
38611      &    FACBW=0D0
38612           DO 340 I=MMIN1,MMAX1
38613             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
38614             IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
38615             KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
38616             DO 330 J=MMIN2,MMAX2
38617               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
38618               IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
38619               KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
38620               KCHH=KCHWI+KCHWJ
38621               IF(IABS(KCHH).NE.2) GOTO 330
38622               FACLR=VINT(180+I)*VINT(180+J)
38623               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38624               IF(I.EQ.J.AND.IABS(I).GT.10) THEN
38625                 FACPRP=0.5D0*(FACPRT+FACPRU)**2
38626               ELSE
38627                 FACPRP=FACPRT**2
38628               ENDIF
38629               NCHN=NCHN+1
38630               ISIG(NCHN,1)=I
38631               ISIG(NCHN,2)=J
38632               ISIG(NCHN,3)=1
38633               SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
38634   330       CONTINUE
38635   340     CONTINUE
38636  
38637         ELSEIF(ISUB.EQ.353) THEN
38638 C...f + fbar -> Z_R0
38639           SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38640           CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38641           HS=SHR*WDTP(0)
38642           FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
38643           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38644           HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
38645           DO 350 I=MMINA,MMAXA
38646             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
38647             IF(IABS(I).LE.8) THEN
38648               EI=KCHG(IABS(I),1)/3D0
38649               AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
38650               VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
38651             ELSE
38652               AI=-(1D0-2D0*XW)
38653               VI=-1D0+4D0*XW
38654             ENDIF
38655             HI=HP*(VI**2+AI**2)
38656             IF(IABS(I).LE.10) HI=HI*FACA/3D0
38657             NCHN=NCHN+1
38658             ISIG(NCHN,1)=I
38659             ISIG(NCHN,2)=-I
38660             ISIG(NCHN,3)=1
38661             SIGH(NCHN)=HI*FACBW*HF
38662   350     CONTINUE
38663  
38664         ELSEIF(ISUB.EQ.354) THEN
38665 C...f + fbar' -> W_R+/-
38666           SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38667           CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38668           HS=SHR*WDTP(0)
38669           FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38670           HP=AEM/(24D0*XW)*SH
38671           DO 370 I=MMIN1,MMAX1
38672             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38673             IA=IABS(I)
38674             DO 360 J=MMIN2,MMAX2
38675               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38676               JA=IABS(J)
38677               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38678               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38679      &        GOTO 360
38680               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38681               HI=HP*2D0
38682               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38683               NCHN=NCHN+1
38684               ISIG(NCHN,1)=I
38685               ISIG(NCHN,2)=J
38686               ISIG(NCHN,3)=1
38687               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38688               SIGH(NCHN)=HI*FACBW*HF
38689   360       CONTINUE
38690   370     CONTINUE
38691         ENDIF
38692  
38693       ELSEIF(ISUB.LE.400) THEN
38694         IF(ISUB.EQ.391) THEN
38695 C...f + fbar -> G*.
38696           KFGSTR=KFPR(ISUB,1)
38697           KCGSTR=PYCOMP(KFGSTR)
38698           CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38699           HS=SHR*WDTP(0)
38700           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38701           FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38702      &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38703 C...Modify cross section in wings of peak.
38704           FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38705           DO 380 I=MMINA,MMAXA
38706             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38707             HI=1D0
38708             IF(IABS(I).LE.10) HI=HI*FACA/3D0
38709             NCHN=NCHN+1
38710             ISIG(NCHN,1)=I
38711             ISIG(NCHN,2)=-I
38712             ISIG(NCHN,3)=1
38713             SIGH(NCHN)=FACG*HI
38714   380     CONTINUE
38715  
38716         ELSEIF(ISUB.EQ.392) THEN
38717 C...g + g -> G*.
38718           KFGSTR=KFPR(ISUB,1)
38719           KCGSTR=PYCOMP(KFGSTR)
38720           CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38721           HS=SHR*WDTP(0)
38722           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38723           FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38724      &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38725 C...Modify cross section in wings of peak.
38726           FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38727           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38728           NCHN=NCHN+1
38729           ISIG(NCHN,1)=21
38730           ISIG(NCHN,2)=21
38731           ISIG(NCHN,3)=1
38732           SIGH(NCHN)=FACG
38733   390     CONTINUE
38734  
38735         ELSEIF(ISUB.EQ.393) THEN
38736 C...q + qbar -> g + G*.
38737           KFGSTR=KFPR(ISUB,2)
38738           KCGSTR=PYCOMP(KFGSTR)
38739           FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38740      &    (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38741      &    3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38742      &    2D0*SH2/(TH*UH))
38743 C...Propagators: as simulated in PYOFSH and as desired
38744           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38745           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38746           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38747           HS=SQRT(SQM4)*WDTP(0)
38748           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38749           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38750           FACG=FACG*HBW4C/HBW4
38751           DO 400 I=MMINA,MMAXA
38752             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38753      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38754             NCHN=NCHN+1
38755             ISIG(NCHN,1)=I
38756             ISIG(NCHN,2)=-I
38757             ISIG(NCHN,3)=1
38758             SIGH(NCHN)=FACG
38759   400     CONTINUE
38760  
38761         ELSEIF(ISUB.EQ.394) THEN
38762 C...q + g -> q + G*.
38763           KFGSTR=KFPR(ISUB,2)
38764           KCGSTR=PYCOMP(KFGSTR)
38765           FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38766      &    (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38767      &    3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38768      &    2D0*TH2*TH/(UH*SH2))
38769 C...Propagators: as simulated in PYOFSH and as desired
38770           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38771           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38772           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38773           HS=SQRT(SQM4)*WDTP(0)
38774           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38775           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38776           FACG=FACG*HBW4C/HBW4
38777           DO 420 I=MMINA,MMAXA
38778             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38779             DO 410 ISDE=1,2
38780               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38781               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38782               NCHN=NCHN+1
38783               ISIG(NCHN,ISDE)=I
38784               ISIG(NCHN,3-ISDE)=21
38785               ISIG(NCHN,3)=1
38786               SIGH(NCHN)=FACG
38787   410       CONTINUE
38788   420     CONTINUE
38789  
38790         ELSEIF(ISUB.EQ.395) THEN
38791 C...g + g -> g + G*.
38792           KFGSTR=KFPR(ISUB,2)
38793           KCGSTR=PYCOMP(KFGSTR)
38794           FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38795      &    ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38796      &    3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38797 C...Propagators: as simulated in PYOFSH and as desired
38798           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38799           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38800           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38801           HS=SQRT(SQM4)*WDTP(0)
38802           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38803           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38804           FACG=FACG*HBW4C/HBW4
38805           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38806             NCHN=NCHN+1
38807             ISIG(NCHN,1)=21
38808             ISIG(NCHN,2)=21
38809             ISIG(NCHN,3)=1
38810             SIGH(NCHN)=FACG
38811           ENDIF
38812         ENDIF
38813       ELSEIF(ISUB.LE.500) THEN
38814         IF(ISUBSV.EQ.481) ISUB=482
38815 c...  GENERIC 2->(1)->2
38816         IF(ISUB.EQ.482) THEN
38817           KFRES=9900001
38818           KCRES=PYCOMP(KFRES)
38819           IF(KCRES.EQ.0) RETURN
38820           IDCY=MDCY(KCRES,2)
38821           KCOL=KCHG(KCRES,2)
38822           KCEM=KCHG(KCRES,1)
38823           FACT=COMFAC
38824           KCF1=PYCOMP(KFPR(ISUB,1))
38825           KCF2=PYCOMP(KFPR(ISUB,2))
38826           IF(ISUBSV.EQ.481) THEN
38827             SQMZR=PMAS(KCRES,1)**2
38828             CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38829             HS=SHR*WDTP(0)
38830             FACBW=SH2/((SH-SQMZR)**2+HS**2)
38831             FACT=FACT*FACBW
38832           ELSE
38833             SQMH=PMAS(KCF1,1)**2
38834             GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
38835 C...Propagators: as simulated in PYOFSH and as desired
38836             HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38837             CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
38838             GMMH3=SQRT(SQM3)*WDTP(0)
38839             HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38840             SQMH=PMAS(KCF2,1)**2
38841             GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
38842             HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38843             CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
38844             GMMH4=SQRT(SQM4)*WDTP(0)
38845             HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38846             FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
38847           ENDIF
38848 
38849           KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
38850           KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
38851           JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
38852           JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
38853           IF(KCOL.EQ.0) THEN
38854             NCOL=1
38855           ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
38856             IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
38857               NCOL=3
38858             ELSE
38859               NCOL=2
38860             ENDIF
38861           ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
38862             NCOL=2
38863           ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
38864      $      JCOL2.EQ.0) THEN
38865             NCOL=1
38866           ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
38867      $      (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
38868             NCOL=1
38869           ELSE
38870             NCOL=2
38871           ENDIF
38872           DO 440 I=MMIN1,MMAX1
38873             IF(KFAC(1,I).EQ.0) GOTO 440
38874             IP=I
38875             IF(IP.EQ.0) IP=21
38876             IA=ABS(IP)
38877             DO 430 J=MMIN2,MMAX2
38878               IF(KFAC(2,J).EQ.0) GOTO 430
38879               JP=J
38880               IF(JP.EQ.0) JP=21
38881               JA=ABS(JP)
38882               IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
38883      $          (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
38884                 KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
38885                 IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
38886                   DO II=1,NCOL
38887                     NCHN=NCHN+1
38888                     ISIG(NCHN,1)=IP
38889                     ISIG(NCHN,2)=JP
38890                     ISIG(NCHN,3)=II
38891                     SIGH(NCHN)=FACT/NCOL
38892                   ENDDO
38893                 ENDIF
38894               ENDIF
38895  430        CONTINUE
38896  440      CONTINUE
38897         ENDIF
38898       ENDIF
38899  
38900       RETURN
38901       END
38902  
38903 C*********************************************************************
38904  
38905 C...PYPDFU
38906 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38907 C...parton distributions according to a few different parametrizations.
38908 C...Note that what is coded is x times the probability distribution,
38909 C...i.e. xq(x,Q2) etc.
38910  
38911       SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38912  
38913 C...Double precision and integer declarations.
38914       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38915       IMPLICIT INTEGER(I-N)
38916       INTEGER PYK,PYCHGE,PYCOMP
38917 C...Commonblocks.
38918       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38919       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38920       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38921       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38922       COMMON/PYINT1/MINT(400),VINT(400)
38923       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38924      &XPDIR(-6:6)
38925       COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38926       COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38927      &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38928      &     XMI(2,240),PT2MI(240),IMISEP(0:240)
38929       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38930      &/PYINT9/,/PYINTM/
38931 C...Local arrays.
38932       DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38933      &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38934       SAVE PPAR
38935  
38936 C...Interface to PDFLIB.
38937       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38938       SAVE /W50513/
38939       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38940      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38941       CHARACTER*20 PARM(20)
38942       DATA VALUE/20*0D0/,PARM/20*' '/
38943  
38944 C...Data related to Schuler-Sjostrand photon distributions.
38945       DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38946  
38947 C...Valence PDF momentum integral parametrizations PER PARTON!
38948       DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38949       DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38950       PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38951      &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38952  
38953 C...Reset parton distributions.
38954       MINT(92)=0
38955       DO 100 KFL=-25,25
38956         XPQ(KFL)=0D0
38957   100 CONTINUE
38958       DO 110 KFL=-6,6
38959         XPVAL(KFL)=0D0
38960   110 CONTINUE
38961  
38962 C...Check x and particle species.
38963       IF(X.LE.0D0.OR.X.GE.1D0) THEN
38964         WRITE(MSTU(11),5000) X
38965         GOTO 9999
38966       ENDIF
38967       KFA=IABS(KF)
38968       IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38969      &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38970      &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38971      &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38972      &KFA.NE.310.AND.KFA.NE.130) THEN
38973         WRITE(MSTU(11),5100) KF
38974         GOTO 9999
38975       ENDIF
38976  
38977 C...Electron (or muon or tau) parton distribution call.
38978       IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38979         CALL PYPDEL(KFA,X,Q2,XPEL)
38980         DO 120 KFL=-25,25
38981           XPQ(KFL)=XPEL(KFL)
38982   120   CONTINUE
38983  
38984 C...Photon parton distribution call (VDM+anomalous).
38985       ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38986         IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38987           CALL PYPDGA(X,Q2,XPGA)
38988           DO 130 KFL=-6,6
38989             XPQ(KFL)=XPGA(KFL)
38990   130     CONTINUE
38991           XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38992           XPVAL(1)=XPVU/4D0
38993           XPVAL(2)=XPVU
38994           XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38995           XPVAL(4)=MIN(XPQ(4),XPVU)
38996           XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38997           XPVAL(-1)=XPVAL(1)
38998           XPVAL(-2)=XPVAL(2)
38999           XPVAL(-3)=XPVAL(3)
39000           XPVAL(-4)=XPVAL(4)
39001           XPVAL(-5)=XPVAL(5)
39002         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39003           Q2MX=Q2
39004           P2MX=0.36D0
39005           IF(MSTP(55).GE.7) P2MX=4.0D0
39006           IF(MSTP(57).EQ.0) Q2MX=P2MX
39007           P2=0D0
39008           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39009           CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39010           DO 140 KFL=-6,6
39011             XPQ(KFL)=XPGA(KFL)
39012             XPVAL(KFL)=VXPDGM(KFL)
39013   140     CONTINUE
39014           VINT(231)=P2MX
39015         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39016           Q2MX=Q2
39017           P2MX=0.36D0
39018           IF(MSTP(55).GE.11) P2MX=4.0D0
39019           IF(MSTP(57).EQ.0) Q2MX=P2MX
39020           P2=0D0
39021           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39022           CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39023           DO 150 KFL=-6,6
39024             XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39025             XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39026   150     CONTINUE
39027           VINT(231)=P2MX
39028         ELSEIF(MSTP(56).EQ.2) THEN
39029 C...Call PDFLIB parton distributions.
39030           PARM(1)='NPTYPE'
39031           VALUE(1)=3
39032           PARM(2)='NGROUP'
39033           VALUE(2)=MSTP(55)/1000
39034           PARM(3)='NSET'
39035           VALUE(3)=MOD(MSTP(55),1000)
39036           IF(MINT(93).NE.3000000+MSTP(55)) THEN
39037             CALL PDFSET(PARM,VALUE)
39038             MINT(93)=3000000+MSTP(55)
39039           ENDIF
39040           XX=X
39041           QQ2=MAX(0D0,Q2MIN,Q2)
39042           IF(MSTP(57).EQ.0) QQ2=Q2MIN
39043           P2=0D0
39044           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39045           IP2=MSTP(60)
39046           IF(MSTP(55).EQ.5004) THEN
39047             IF(5D0*P2.LT.QQ2.AND.
39048      &      QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
39049      &      P2.GE.0D0.AND.P2.LT.10D0.AND.
39050      &      XX.GT.1D-4.AND.XX.LT.1D0) THEN
39051               CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39052      &        BOT,TOP,GLU)
39053             ELSE
39054               UPV=0D0
39055               DNV=0D0
39056               USEA=0D0
39057               DSEA=0D0
39058               STR=0D0
39059               CHM=0D0
39060               BOT=0D0
39061               TOP=0D0
39062               GLU=0D0
39063             ENDIF
39064           ELSE
39065             IF(P2.LT.QQ2) THEN
39066               CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39067      &        BOT,TOP,GLU)
39068             ELSE
39069               UPV=0D0
39070               DNV=0D0
39071               USEA=0D0
39072               DSEA=0D0
39073               STR=0D0
39074               CHM=0D0
39075               BOT=0D0
39076               TOP=0D0
39077               GLU=0D0
39078             ENDIF
39079           ENDIF
39080           VINT(231)=Q2MIN
39081           XPQ(0)=GLU
39082           XPQ(1)=DNV
39083           XPQ(-1)=DNV
39084           XPQ(2)=UPV
39085           XPQ(-2)=UPV
39086           XPQ(3)=STR
39087           XPQ(-3)=STR
39088           XPQ(4)=CHM
39089           XPQ(-4)=CHM
39090           XPQ(5)=BOT
39091           XPQ(-5)=BOT
39092           XPQ(6)=TOP
39093           XPQ(-6)=TOP
39094           XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39095           XPVAL(1)=XPVU/4D0
39096           XPVAL(2)=XPVU
39097           XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39098           XPVAL(4)=MIN(XPQ(4),XPVU)
39099           XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39100           XPVAL(-1)=XPVAL(1)
39101           XPVAL(-2)=XPVAL(2)
39102           XPVAL(-3)=XPVAL(3)
39103           XPVAL(-4)=XPVAL(4)
39104           XPVAL(-5)=XPVAL(5)
39105         ELSE
39106           WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
39107         ENDIF
39108  
39109 C...Pion/gammaVDM parton distribution call.
39110       ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
39111      &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39112         IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
39113      &  MSTP(55).LE.12) THEN
39114           ISET=1+MOD(MSTP(55)-1,4)
39115           Q2MX=Q2
39116           P2MX=0.36D0
39117           IF(ISET.GE.3) P2MX=4.0D0
39118           IF(MSTP(57).EQ.0) Q2MX=P2MX
39119           P2=0D0
39120           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39121           CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39122           DO 160 KFL=-6,6
39123             XPQ(KFL)=XPVMD(KFL)
39124             XPVAL(KFL)=VXPVMD(KFL)
39125   160     CONTINUE
39126           VINT(231)=P2MX
39127         ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
39128           CALL PYPDPI(X,Q2,XPPI)
39129           DO 170 KFL=-6,6
39130             XPQ(KFL)=XPPI(KFL)
39131   170     CONTINUE
39132           XPVAL(2)=XPQ(2)-XPQ(-2)
39133           XPVAL(-1)=XPQ(-1)-XPQ(1)
39134         ELSEIF(MSTP(54).EQ.2) THEN
39135 C...Call PDFLIB parton distributions.
39136           PARM(1)='NPTYPE'
39137           VALUE(1)=2
39138           PARM(2)='NGROUP'
39139           VALUE(2)=MSTP(53)/1000
39140           PARM(3)='NSET'
39141           VALUE(3)=MOD(MSTP(53),1000)
39142           IF(MINT(93).NE.2000000+MSTP(53)) THEN
39143             CALL PDFSET(PARM,VALUE)
39144             MINT(93)=2000000+MSTP(53)
39145           ENDIF
39146           XX=X
39147           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39148           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39149           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39150           VINT(231)=Q2MIN
39151           XPQ(0)=GLU
39152           XPQ(1)=DSEA
39153           XPQ(-1)=UPV+DSEA
39154           XPQ(2)=UPV+USEA
39155           XPQ(-2)=USEA
39156           XPQ(3)=STR
39157           XPQ(-3)=STR
39158           XPQ(4)=CHM
39159           XPQ(-4)=CHM
39160           XPQ(5)=BOT
39161           XPQ(-5)=BOT
39162           XPQ(6)=TOP
39163           XPQ(-6)=TOP
39164           XPVAL(2)=UPV
39165           XPVAL(-1)=UPV
39166         ELSE
39167           WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
39168         ENDIF
39169  
39170 C...Anomalous photon parton distribution call.
39171       ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
39172         Q2MX=Q2
39173         P2MX=PARP(15)**2
39174         IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
39175           IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
39176           IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
39177           IF(MSTP(57).EQ.0) Q2MX=P2MX
39178           P2=0D0
39179           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39180           CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39181           DO 180 KFL=-6,6
39182             XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
39183             XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
39184   180     CONTINUE
39185           VINT(231)=P2MX
39186         ELSEIF(MSTP(56).EQ.1) THEN
39187           IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
39188           IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
39189           IF(MSTP(57).EQ.0) Q2MX=P2MX
39190           P2=0D0
39191           IF(VINT(120).LT.0D0) P2=VINT(120)**2
39192           CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39193           DO 190 KFL=-6,6
39194             XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39195             XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39196   190     CONTINUE
39197           VINT(231)=P2MX
39198         ELSEIF(MSTP(56).EQ.2) THEN
39199           IF(MSTP(57).EQ.0) Q2MX=P2MX
39200           CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
39201           DO 200 KFL=-6,6
39202             XPQ(KFL)=XPGA(KFL)
39203             XPVAL(KFL)=VXPGA(KFL)
39204   200     CONTINUE
39205           VINT(231)=P2MX
39206         ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
39207           IF(MSTP(57).EQ.0) Q2MX=P2MX
39208           CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39209           DO 210 KFL=-6,6
39210             XPQ(KFL)=XPGA(KFL)
39211             XPVAL(KFL)=VXPGA(KFL)
39212   210     CONTINUE
39213           VINT(231)=P2MX
39214         ELSE
39215   220     RKF=11D0*PYR(0)
39216           KFR=1
39217           IF(RKF.GT.1D0) KFR=2
39218           IF(RKF.GT.5D0) KFR=3
39219           IF(RKF.GT.6D0) KFR=4
39220           IF(RKF.GT.10D0) KFR=5
39221           IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
39222           IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
39223           IF(MSTP(57).EQ.0) Q2MX=P2MX
39224           CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39225           DO 230 KFL=-6,6
39226             XPQ(KFL)=XPGA(KFL)
39227             XPVAL(KFL)=VXPGA(KFL)
39228   230     CONTINUE
39229           VINT(231)=P2MX
39230         ENDIF
39231  
39232 C...Proton parton distribution call.
39233       ELSE
39234         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
39235           CALL PYPDPR(X,Q2,XPPR)
39236           DO 240 KFL=-6,6
39237             XPQ(KFL)=XPPR(KFL)
39238   240     CONTINUE
39239 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
39240           XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
39241           XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
39242         ELSEIF(MSTP(52).EQ.2) THEN
39243 C...Call PDFLIB parton distributions.
39244           PARM(1)='NPTYPE'
39245           VALUE(1)=1
39246           PARM(2)='NGROUP'
39247           VALUE(2)=MSTP(51)/1000
39248           PARM(3)='NSET'
39249           VALUE(3)=MOD(MSTP(51),1000)
39250           IF(MINT(93).NE.1000000+MSTP(51)) THEN
39251             CALL PDFSET(PARM,VALUE)
39252             MINT(93)=1000000+MSTP(51)
39253           ENDIF
39254           XX=X
39255           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39256           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39257           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39258           VINT(231)=Q2MIN
39259           XPQ(0)=GLU
39260           XPQ(1)=DNV+DSEA
39261           XPQ(-1)=DSEA
39262           XPQ(2)=UPV+USEA
39263           XPQ(-2)=USEA
39264           XPQ(3)=STR
39265           XPQ(-3)=STR
39266           XPQ(4)=CHM
39267           XPQ(-4)=CHM
39268           XPQ(5)=BOT
39269           XPQ(-5)=BOT
39270           XPQ(6)=TOP
39271           XPQ(-6)=TOP
39272           XPVAL(1)=DNV
39273           XPVAL(2)=UPV
39274         ELSE
39275           WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
39276         ENDIF
39277       ENDIF
39278  
39279 C...Isospin average for pi0/gammaVDM.
39280       IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39281         IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
39282           XPV=XPQ(2)-XPQ(1)
39283           XPQ(2)=XPQ(1)
39284           XPQ(-2)=XPQ(-1)
39285         ELSE
39286           XPS=0.5D0*(XPQ(1)+XPQ(-2))
39287           XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39288           XPQ(2)=XPS
39289           XPQ(-1)=XPS
39290         ENDIF
39291         XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
39292      &  XPVAL(3)+XPVAL(4)+XPVAL(5)
39293         DO 250 KFL=-6,6
39294           XPVAL(KFL)=0D0
39295   250   CONTINUE
39296         IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
39297           XPQ(1)=XPQ(1)+0.2D0*XPV
39298           XPQ(2)=XPQ(2)+0.8D0*XPV
39299           XPVAL(1)=0.2D0*XPVL
39300           XPVAL(2)=0.8D0*XPVL
39301         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
39302           XPQ(3)=XPQ(3)+XPV
39303           XPVAL(3)=XPVL
39304         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
39305           XPQ(4)=XPQ(4)+XPV
39306           XPVAL(4)=XPVL
39307           IF(MSTP(55).GE.9) THEN
39308             DO 260 KFL=-6,6
39309               XPQ(KFL)=0D0
39310   260       CONTINUE
39311           ENDIF
39312         ELSE
39313           XPQ(1)=XPQ(1)+0.5D0*XPV
39314           XPQ(2)=XPQ(2)+0.5D0*XPV
39315           XPVAL(1)=0.5D0*XPVL
39316           XPVAL(2)=0.5D0*XPVL
39317         ENDIF
39318         DO 270 KFL=1,6
39319           XPQ(-KFL)=XPQ(KFL)
39320           XPVAL(-KFL)=XPVAL(KFL)
39321   270   CONTINUE
39322  
39323 C...Rescale for gammaVDM by effective gamma -> rho coupling.
39324 C+++Do not rescale?
39325         IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
39326      &  .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
39327           DO 280 KFL=-6,6
39328             XPQ(KFL)=VINT(281)*XPQ(KFL)
39329             XPVAL(KFL)=VINT(281)*XPVAL(KFL)
39330   280     CONTINUE
39331           VINT(232)=VINT(281)*XPV
39332         ENDIF
39333  
39334 C...Simple recipes for kaons.
39335       ELSEIF(KFA.EQ.321) THEN
39336         XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
39337         XPQ(-1)=XPQ(1)
39338         XPVAL(-3)=XPVAL(-1)
39339         XPVAL(-1)=0D0
39340       ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
39341         XPS=0.5D0*(XPQ(1)+XPQ(-2))
39342         XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39343         XPQ(2)=XPS
39344         XPQ(-1)=XPS
39345         XPQ(1)=XPQ(1)+0.5D0*XPV
39346         XPQ(-1)=XPQ(-1)+0.5D0*XPV
39347         XPQ(3)=XPQ(3)+0.5D0*XPV
39348         XPQ(-3)=XPQ(-3)+0.5D0*XPV
39349         XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
39350         XPVAL(2)=0D0
39351         XPVAL(-1)=0D0
39352         XPVAL(1)=0.5D0*XPV
39353         XPVAL(-1)=0.5D0*XPV
39354         XPVAL(3)=0.5D0*XPV
39355         XPVAL(-3)=0.5D0*XPV
39356  
39357 C...Isospin conjugation for neutron.
39358       ELSEIF(KFA.EQ.2112) THEN
39359         XPSV=XPQ(1)
39360         XPQ(1)=XPQ(2)
39361         XPQ(2)=XPSV
39362         XPSV=XPQ(-1)
39363         XPQ(-1)=XPQ(-2)
39364         XPQ(-2)=XPSV
39365         XPSV=XPVAL(1)
39366         XPVAL(1)=XPVAL(2)
39367         XPVAL(2)=XPSV
39368  
39369 C...Simple recipes for hyperon (average valence parton distribution).
39370       ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
39371      &  .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
39372         XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
39373         XPS=0.5D0*(XPQ(-1)+XPQ(-2))
39374         XPQ(1)=XPS
39375         XPQ(2)=XPS
39376         XPQ(-1)=XPS
39377         XPQ(-2)=XPS
39378         XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
39379         XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
39380         XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
39381         XPV=(XPVAL(1)+XPVAL(2))/3D0
39382         XPVAL(1)=0D0
39383         XPVAL(2)=0D0
39384         XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
39385         XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
39386         XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
39387       ENDIF
39388  
39389 C...Charge conjugation for antiparticle.
39390       IF(KF.LT.0) THEN
39391         DO 290 KFL=1,25
39392           IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
39393           XPSV=XPQ(KFL)
39394           XPQ(KFL)=XPQ(-KFL)
39395           XPQ(-KFL)=XPSV
39396   290   CONTINUE
39397         DO 300 KFL=1,6
39398           XPSV=XPVAL(KFL)
39399           XPVAL(KFL)=XPVAL(-KFL)
39400           XPVAL(-KFL)=XPSV
39401   300  CONTINUE
39402       ENDIF
39403  
39404 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
39405 C...Set side.
39406       JS=MINT(30)
39407 C...Only reshape PDFs for the non-first interactions;
39408 C...But need valence/sea separation already from first interaction.
39409       IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
39410         KFVSEL=KFIVAL(JS,1)
39411 C...If valence quark kicked out of pi0 or gamma then that decides
39412 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
39413         IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
39414           XPVL=0D0
39415           DO 310 KFL=1,6
39416             XPVL=XPVL+XPVAL(KFL)
39417             XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
39418             XPVAL(KFL)=0D0
39419   310     CONTINUE
39420           XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
39421           XPVAL(IABS(KFVSEL))=XPVL
39422           DO 320 KFL=1,6
39423             XPQ(-KFL)=XPQ(KFL)
39424             XPVAL(-KFL)=XPVAL(KFL)
39425   320     CONTINUE
39426  
39427 C...If valence quark kicked out of K0S or K0S then that decides whether
39428 C...we should consider state as d sbar or s dbar.
39429         ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
39430           KFS=1
39431           IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
39432           XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39433           XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39434           XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39435           XPVAL(-KFS)=0D0
39436           KFS=-3*KFS
39437           XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39438           XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39439           XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39440           XPVAL(-KFS)=0D0
39441         ENDIF
39442  
39443 C...XPQ distributions are nominal for a (signed) beam particle
39444 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
39445         CMPFAC=1D0
39446         NRESC=0
39447  345    NRESC=NRESC+1
39448         PVCTOT(JS,-1)=0D0
39449         PVCTOT(JS, 0)=0D0
39450         PVCTOT(JS, 1)=0D0
39451         DO 350 IFL=-6,6
39452           IF(IFL.EQ.0) GOTO 350
39453  
39454 C...Count up number of original IFL valence quarks.
39455           IVORG=0
39456           IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
39457           IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
39458           IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
39459 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
39460 C...bookkeep as if d dbar (for total momentum sum in valence sector).
39461           IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
39462 C...Count down number of remaining IFL valence quarks. Skip current
39463 C...interaction initiator.
39464           IVREM=IVORG
39465           DO 330 I1=1,NMI(JS)
39466             IF (I1.EQ.MINT(36)) GOTO 330
39467             IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
39468      &           IVREM=IVREM-1
39469   330     CONTINUE
39470  
39471 C...Separate out original VALENCE and SEA content.
39472           VAL=XPVAL(IFL)
39473           SEA=MAX(0D0,XPQ(IFL)-VAL)
39474           XPSVC(IFL,0)=VAL
39475           XPSVC(IFL,-1)=SEA
39476  
39477 C...Rescale valence content if changed.
39478           IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
39479      &    (VAL*IVREM)/IVORG
39480  
39481 C...Momentum integrals of original and removed valence quarks.
39482           IF(IVORG.NE.0) THEN
39483 C...For p/n/pbar/nbar beams can split into d_val and u_val.
39484 C...Isospin conjugation for neutrons
39485             IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
39486               IAFLP=IABS(IFL)
39487               IF (KFA.EQ.2112) IAFLP=3-IAFLP
39488               VPAVG=PAVG(IAFLP,Q2)
39489 C...For other baryons average d_val and u_val, like for PDFs.
39490             ELSEIF(KFA.GT.1000) THEN
39491               VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
39492 C...For mesons and photon average d_val and u_val and scale by 3/2.
39493 C...Very crude, especially for photon.
39494             ELSE
39495               VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
39496             ENDIF
39497             PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
39498             PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
39499           ENDIF
39500  
39501 C...Now add companions (at X with partner having been at Z=XASSOC).
39502 C...NOTE: due to the assumed simple x scaling, the partner was at what
39503 C...corresponds to a higher Z than XASSOC, if there were intermediate
39504 C...scatterings. Nothing done about that for the moment.
39505           DO 340 IVC=1,NVC(JS,IFL)
39506 C...Skip companions that have been kicked out
39507             IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
39508               XPSVC(IFL,IVC)=0D0
39509               GOTO 340
39510             ELSE
39511 C...Momentum fraction of the partner quark.
39512 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
39513               XS=XASSOC(JS,IFL,IVC)
39514               XREM=VINT(142+JS)
39515               YS=XS/(XREM+XS)
39516 C...Momentum fraction of the companion quark.
39517 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
39518               Y=X*(1D0-YS)
39519               XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
39520 C...Add to momentum sum, with rescaling compensation factor.
39521               XCFAC=(XREM+XS)/XREM*CMPFAC
39522               PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
39523             ENDIF
39524   340     CONTINUE
39525   350   CONTINUE
39526  
39527 C...Wait until all flavours treated, then rescale seas and gluon.
39528         XPSVC(0,-1)=XPQ(0)
39529         XPSVC(0,0)=0D0
39530         RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
39531         IF (RSFAC.LE.0D0) THEN
39532 C...First calculate factor needed to exactly restore pz cons.
39533           IF (NRESC.EQ.1) CMPFAC =
39534      &         (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
39535 C...Add a bit of headroom
39536           CMPFAC=0.99*CMPFAC
39537 C...Try a few times if more headroom is needed, then print error message.
39538           IF (NRESC.LE.10) GOTO 345
39539           CALL PYERRM(15,
39540      &         '(PYPDFU:) Negative reshaping factor persists!')
39541           WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
39542           RSFAC=0D0
39543         ENDIF
39544         DO 370 IFL=-6,6
39545           XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
39546 C...Also store resulting distributions in XPQ
39547           XPQ(IFL)=0D0
39548           DO 360 ISVC=-1,NVC(JS,IFL)
39549             XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
39550   360     CONTINUE
39551   370   CONTINUE
39552 C...Save companion reweighting factor for PYPTIS.
39553         VINT(140)=CMPFAC
39554       ENDIF
39555  
39556  
39557 C...Allow gluon also in position 21.
39558       XPQ(21)=XPQ(0)
39559  
39560 C...Check positivity and reset above maximum allowed flavour.
39561       DO 380 KFL=-25,25
39562         XPQ(KFL)=MAX(0D0,XPQ(KFL))
39563         IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
39564   380 CONTINUE
39565  
39566 C...Formats for error printouts.
39567  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39568  5100 FORMAT(' Error: illegal particle code for parton distribution;',
39569      &' KF =',I5)
39570  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
39571      &3I5)
39572  5300 FORMAT(' Original valence momentum fraction : ',F6.3/
39573      &       ' Removed valence momentum fraction  : ',F6.3/
39574      &       ' Added companion momentum fraction  : ',F6.3/
39575      &       ' Resulting rescale factor           : ',F6.3)
39576  
39577 C...Reset side pointer and return
39578  9999 MINT(30)=0
39579  
39580       RETURN
39581       END
39582  
39583 C*********************************************************************
39584  
39585 C...PYPDFL
39586 C...Gives proton parton distribution at small x and/or Q^2 according to
39587 C...correct limiting behaviour.
39588  
39589       SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
39590  
39591 C...Double precision and integer declarations.
39592       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39593       IMPLICIT INTEGER(I-N)
39594       INTEGER PYK,PYCHGE,PYCOMP
39595 C...Commonblocks.
39596       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39597       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39598       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39599       COMMON/PYINT1/MINT(400),VINT(400)
39600       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39601 C...Local arrays.
39602       DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
39603       DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
39604  
39605 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
39606       MINT(92)=0
39607       KFA=IABS(KF)
39608       IACC=0
39609       IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
39610       IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
39611       IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
39612       IF(IACC.EQ.0) THEN
39613         CALL PYPDFU(KF,X,Q2,XPQ)
39614         RETURN
39615       ENDIF
39616  
39617 C...Reset. Check x.
39618       DO 100 KFL=-25,25
39619         XPQ(KFL)=0D0
39620   100 CONTINUE
39621       IF(X.LE.0D0.OR.X.GE.1D0) THEN
39622         WRITE(MSTU(11),5000) X
39623         RETURN
39624       ENDIF
39625  
39626 C...Define valence content.
39627       KFC=KF
39628       NV1=2
39629       NV2=1
39630       IF(KF.EQ.2212) THEN
39631         KFV1=2
39632         KFV2=1
39633       ELSEIF(KF.EQ.-2212) THEN
39634         KFV1=-2
39635         KFV2=-1
39636       ELSEIF(KF.EQ.2112) THEN
39637         KFV1=1
39638         KFV2=2
39639       ELSEIF(KF.EQ.-2112) THEN
39640         KFV1=-1
39641         KFV2=-2
39642       ELSEIF(KF.EQ.211) THEN
39643         NV1=1
39644         KFV1=2
39645         KFV2=-1
39646       ELSEIF(KF.EQ.-211) THEN
39647         NV1=1
39648         KFV1=-2
39649         KFV2=1
39650       ELSEIF(MINT(105).LE.223) THEN
39651         KFV1=1
39652         WTV1=0.2D0
39653         KFV2=2
39654         WTV2=0.8D0
39655       ELSEIF(MINT(105).EQ.333) THEN
39656         KFV1=3
39657         WTV1=1.0D0
39658         KFV2=1
39659         WTV2=0.0D0
39660       ELSEIF(MINT(105).EQ.443) THEN
39661         KFV1=4
39662         WTV1=1.0D0
39663         KFV2=1
39664         WTV2=0.0D0
39665       ENDIF
39666  
39667 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
39668       MINT30=MINT(30)
39669       CALL PYPDFU(KFC,X,Q2,XPA)
39670       Q2MN=MAX(3D0,VINT(231))
39671       Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
39672       XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
39673  
39674 C...Large Q2 and large x: naive call is enough.
39675       IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
39676         DO 110 KFL=-25,25
39677           XPQ(KFL)=XPA(KFL)
39678   110   CONTINUE
39679         MINT(92)=1
39680  
39681 C...Small Q2 and large x: dampen boundary value.
39682       ELSEIF(X.GT.XMN) THEN
39683  
39684 C...Evaluate at boundary and define dampening factors.
39685         MINT(30)=MINT30
39686         CALL PYPDFU(KFC,X,Q2MN,XPA)
39687         FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
39688         FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
39689  
39690 C...Separate valence and sea parts of parton distribution.
39691         IF(KFA.NE.22) THEN
39692           XFV1=XPA(KFV1)-XPA(-KFV1)
39693           XPA(KFV1)=XPA(-KFV1)
39694           XFV2=XPA(KFV2)-XPA(-KFV2)
39695           XPA(KFV2)=XPA(-KFV2)
39696         ELSE
39697           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39698           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39699           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39700           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39701         ENDIF
39702  
39703 C...Dampen valence and sea separately. Put back together.
39704         DO 120 KFL=-25,25
39705           XPQ(KFL)=FS*XPA(KFL)
39706   120   CONTINUE
39707         IF(KFA.NE.22) THEN
39708           XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
39709           XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
39710         ELSE
39711           XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
39712           XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
39713           XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
39714           XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
39715         ENDIF
39716         MINT(92)=2
39717  
39718 C...Large Q2 and small x: interpolate behaviour.
39719       ELSEIF(Q2.GT.Q2MN) THEN
39720  
39721 C...Evaluate at extremes and define coefficients for interpolation.
39722         MINT(30)=MINT30
39723         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39724         VI232A=VINT(232)
39725         MINT(30)=MINT30
39726         CALL PYPDFU(KFC,X,Q2B,XPB)
39727         VI232B=VINT(232)
39728         FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
39729         FVA=(X/XMN)**0.45D0*FLA
39730         FSA=(X/XMN)**(-0.08D0)*FLA
39731         FB=1D0-FLA
39732  
39733 C...Separate valence and sea parts of parton distribution.
39734         IF(KFA.NE.22) THEN
39735           XFVA1=XPA(KFV1)-XPA(-KFV1)
39736           XPA(KFV1)=XPA(-KFV1)
39737           XFVA2=XPA(KFV2)-XPA(-KFV2)
39738           XPA(KFV2)=XPA(-KFV2)
39739           XFVB1=XPB(KFV1)-XPB(-KFV1)
39740           XPB(KFV1)=XPB(-KFV1)
39741           XFVB2=XPB(KFV2)-XPB(-KFV2)
39742           XPB(KFV2)=XPB(-KFV2)
39743         ELSE
39744           XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39745           XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39746           XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39747           XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39748           XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39749           XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39750           XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39751           XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39752         ENDIF
39753  
39754 C...Interpolate for valence and sea. Put back together.
39755         DO 130 KFL=-25,25
39756           XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39757   130   CONTINUE
39758         IF(KFA.NE.22) THEN
39759           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39760           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39761         ELSE
39762           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39763           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39764           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39765           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39766         ENDIF
39767         MINT(92)=3
39768  
39769 C...Small Q2 and small x: dampen boundary value and add term.
39770       ELSE
39771  
39772 C...Evaluate at boundary and define dampening factors.
39773         MINT(30)=MINT30
39774         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39775         FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39776         FA=1D0-FB
39777         FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39778         FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39779         FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39780         FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39781         FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39782         FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39783  
39784 C...Separate valence and sea parts of parton distribution.
39785         IF(KFA.NE.22) THEN
39786           XFV1=XPA(KFV1)-XPA(-KFV1)
39787           XPA(KFV1)=XPA(-KFV1)
39788           XFV2=XPA(KFV2)-XPA(-KFV2)
39789           XPA(KFV2)=XPA(-KFV2)
39790         ELSE
39791           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39792           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39793           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39794           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39795         ENDIF
39796  
39797 C...Dampen valence and sea separately. Add constant terms.
39798 C...Put back together.
39799         DO 140 KFL=-25,25
39800           XPQ(KFL)=FSA*XPA(KFL)
39801   140   CONTINUE
39802         IF(KFA.NE.22) THEN
39803           DO 150 KFL=-3,3
39804             XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39805   150     CONTINUE
39806           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39807           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39808         ELSE
39809           DO 160 KFL=-3,3
39810             XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39811   160     CONTINUE
39812           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39813           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39814           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39815           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39816         ENDIF
39817         XPQ(21)=XPQ(0)
39818         MINT(92)=4
39819       ENDIF
39820  
39821 C...Format for error printout.
39822  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39823  
39824       RETURN
39825       END
39826  
39827 C*********************************************************************
39828  
39829 C...PYPDEL
39830 C...Gives electron (or muon, or tau) parton distribution.
39831  
39832       SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39833  
39834 C...Double precision and integer declarations.
39835       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39836       IMPLICIT INTEGER(I-N)
39837       INTEGER PYK,PYCHGE,PYCOMP
39838 C...Commonblocks.
39839       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39840       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39841       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39842       COMMON/PYINT1/MINT(400),VINT(400)
39843       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39844 C...Local arrays.
39845       DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39846  
39847 C...Interface to PDFLIB.
39848       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39849       SAVE /W50513/
39850       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39851      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39852       CHARACTER*20 PARM(20)
39853       DATA VALUE/20*0D0/,PARM/20*' '/
39854  
39855 C...Some common constants.
39856       DO 100 KFL=-25,25
39857         XPEL(KFL)=0D0
39858   100 CONTINUE
39859       AEM=PARU(101)
39860       PME=PMAS(11,1)
39861       IF(KFA.EQ.13) PME=PMAS(13,1)
39862       IF(KFA.EQ.15) PME=PMAS(15,1)
39863       XL=LOG(MAX(1D-10,X))
39864       X1L=LOG(MAX(1D-10,1D0-X))
39865       HLE=LOG(MAX(3D0,Q2/PME**2))
39866       HBE2=(AEM/PARU(1))*(HLE-1D0)
39867  
39868 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39869 C...LEP 1, CERN 89-08, p. 34
39870       IF(MSTP(59).LE.1) THEN
39871         HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39872      &  (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39873         HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39874      &  0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39875      &  4D0*XL/(1D0-X)-5D0-X)
39876       ELSE
39877         HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39878      &  PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39879      &  (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39880       ENDIF
39881 C...Zero distribution for very large x and rescale it for intermediate.
39882       IF(X.GT.1D0-1D-10) THEN
39883         HEE=0D0
39884       ELSEIF(X.GT.1D0-1D-7) THEN
39885         HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39886       ENDIF
39887       XPEL(KFA)=X*HEE
39888  
39889 C...Photon and (transverse) W- inside electron.
39890       AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39891       IF(MSTP(13).LE.1) THEN
39892         HLG=HLE
39893       ELSE
39894         HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39895       ENDIF
39896       XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39897       HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39898       XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39899  
39900 C...Electron or positron inside photon inside electron.
39901       IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39902         XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39903      &  2D0*X*(1D0+X)*XL)
39904         XPEL(11)=XPEL(11)+XFSEA
39905         XPEL(-11)=XFSEA
39906  
39907 C...Initialize PDFLIB photon parton distributions.
39908         IF(MSTP(56).EQ.2) THEN
39909           PARM(1)='NPTYPE'
39910           VALUE(1)=3
39911           PARM(2)='NGROUP'
39912           VALUE(2)=MSTP(55)/1000
39913           PARM(3)='NSET'
39914           VALUE(3)=MOD(MSTP(55),1000)
39915           IF(MINT(93).NE.3000000+MSTP(55)) THEN
39916             CALL PDFSET(PARM,VALUE)
39917             MINT(93)=3000000+MSTP(55)
39918           ENDIF
39919         ENDIF
39920  
39921 C...Quarks and gluons inside photon inside electron:
39922 C...numerical convolution required.
39923         DO 110 KFL=0,6
39924           SXP(KFL)=0D0
39925   110   CONTINUE
39926         SUMXPP=0D0
39927         ITER=-1
39928   120   ITER=ITER+1
39929         SUMXP=SUMXPP
39930         NSTP=2**(ITER-1)
39931         IF(ITER.EQ.0) NSTP=2
39932         DO 130 KFL=0,6
39933           SXP(KFL)=0.5D0*SXP(KFL)
39934   130   CONTINUE
39935         WTSTP=0.5D0/NSTP
39936         IF(ITER.EQ.0) WTSTP=0.5D0
39937 C...Pick grid of x_{gamma} values logarithmically even.
39938         DO 150 ISTP=1,NSTP
39939           IF(ITER.EQ.0) THEN
39940             XLE=XL*(ISTP-1)
39941           ELSE
39942             XLE=XL*(ISTP-0.5D0)/NSTP
39943           ENDIF
39944           XE=MIN(1D0-1D-10,EXP(XLE))
39945           XG=MIN(1D0-1D-10,X/XE)
39946 C...Evaluate photon inside electron parton distribution for convolution.
39947           XPGP=1D0+(1D0-XE)**2
39948           IF(MSTP(13).LE.1) THEN
39949             XPGP=XPGP*HLE
39950           ELSE
39951             XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39952           ENDIF
39953 C...Evaluate photon parton distributions for convolution.
39954           IF(MSTP(56).EQ.1) THEN
39955             IF(MSTP(55).EQ.1) THEN
39956               CALL PYPDGA(XG,Q2,XPGA)
39957             ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39958               Q2MX=Q2
39959               P2MX=0.36D0
39960               IF(MSTP(55).GE.7) P2MX=4.0D0
39961               IF(MSTP(57).EQ.0) Q2MX=P2MX
39962               P2=0D0
39963               IF(VINT(120).LT.0D0) P2=VINT(120)**2
39964               CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39965               VINT(231)=P2MX
39966             ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39967               Q2MX=Q2
39968               P2MX=0.36D0
39969               IF(MSTP(55).GE.11) P2MX=4.0D0
39970               IF(MSTP(57).EQ.0) Q2MX=P2MX
39971               P2=0D0
39972               IF(VINT(120).LT.0D0) P2=VINT(120)**2
39973               CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39974               VINT(231)=P2MX
39975             ENDIF
39976             DO 140 KFL=0,5
39977               SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39978   140       CONTINUE
39979           ELSEIF(MSTP(56).EQ.2) THEN
39980 C...Call PDFLIB parton distributions.
39981             XX=XG
39982             QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39983             IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39984             CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39985             SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39986             SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39987             SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39988             SXP(3)=SXP(3)+WTSTP*XPGP*STR
39989             SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39990             SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39991             SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39992           ENDIF
39993   150   CONTINUE
39994         SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39995         IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39996      &  PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39997  
39998 C...Put convolution into output arrays.
39999         FCONV=AEMP*(-XL)
40000         XPEL(0)=FCONV*SXP(0)
40001         DO 160 KFL=1,6
40002           XPEL(KFL)=FCONV*SXP(KFL)
40003           XPEL(-KFL)=XPEL(KFL)
40004   160   CONTINUE
40005       ENDIF
40006  
40007       RETURN
40008       END
40009  
40010 C*********************************************************************
40011  
40012 C...PYPDGA
40013 C...Gives photon parton distribution.
40014  
40015       SUBROUTINE PYPDGA(X,Q2,XPGA)
40016  
40017 C...Double precision and integer declarations.
40018       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40019       IMPLICIT INTEGER(I-N)
40020       INTEGER PYK,PYCHGE,PYCOMP
40021 C...Commonblocks.
40022       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40023       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40024       COMMON/PYINT1/MINT(400),VINT(400)
40025       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40026 C...Local arrays.
40027       DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
40028      &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
40029      &DGCS(4,3),DGDS(4,3),DGES(4,3)
40030  
40031 C...The following data lines are coefficients needed in the
40032 C...Drees and Grassie photon parton distribution parametrization.
40033       DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
40034      &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
40035       DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
40036      &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
40037       DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
40038      &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
40039       DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
40040      &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
40041       DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
40042      &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
40043       DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
40044      &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
40045       DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
40046      &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
40047       DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
40048      &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
40049       DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
40050      &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
40051       DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
40052      &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
40053       DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
40054      &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
40055       DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
40056      &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
40057       DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
40058      &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
40059  
40060 C...Photon parton distribution from Drees and Grassie.
40061 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
40062       DO 100 KFL=-6,6
40063         XPGA(KFL)=0D0
40064   100 CONTINUE
40065       VINT(231)=1D0
40066       IF(MSTP(57).LE.0) THEN
40067         T=LOG(1D0/0.16D0)
40068       ELSE
40069         T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
40070       ENDIF
40071       X1=1D0-X
40072       NF=3
40073       IF(Q2.GT.25D0) NF=4
40074       IF(Q2.GT.300D0) NF=5
40075       NFE=NF-2
40076       AEM=PARU(101)
40077  
40078 C...Evaluate gluon content.
40079       DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
40080       DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
40081       DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
40082       XPGL=DGA*X**DGB*X1**DGC
40083  
40084 C...Evaluate up- and down-type quark content.
40085       DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
40086       DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
40087       DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
40088       DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
40089       DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
40090       XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40091       DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
40092       DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
40093       DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
40094       DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
40095       DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
40096       DGF=9D0
40097       IF(NF.EQ.4) DGF=10D0
40098       IF(NF.EQ.5) DGF=55D0/6D0
40099       XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40100       IF(NF.LE.3) THEN
40101         XPQU=(XPQS+9D0*XPQN)/6D0
40102         XPQD=(XPQS-4.5D0*XPQN)/6D0
40103       ELSEIF(NF.EQ.4) THEN
40104         XPQU=(XPQS+6D0*XPQN)/8D0
40105         XPQD=(XPQS-6D0*XPQN)/8D0
40106       ELSE
40107         XPQU=(XPQS+7.5D0*XPQN)/10D0
40108         XPQD=(XPQS-5D0*XPQN)/10D0
40109       ENDIF
40110  
40111 C...Put into output arrays.
40112       XPGA(0)=AEM*XPGL
40113       XPGA(1)=AEM*XPQD
40114       XPGA(2)=AEM*XPQU
40115       XPGA(3)=AEM*XPQD
40116       IF(NF.GE.4) XPGA(4)=AEM*XPQU
40117       IF(NF.GE.5) XPGA(5)=AEM*XPQD
40118       DO 110 KFL=1,6
40119         XPGA(-KFL)=XPGA(KFL)
40120   110 CONTINUE
40121  
40122       RETURN
40123       END
40124  
40125 C*********************************************************************
40126  
40127 C...PYGGAM
40128 C...Constructs the F2 and parton distributions of the photon
40129 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40130 C...For F2, c and b are included by the Bethe-Heitler formula;
40131 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40132 C...Contains the SaS sets 1D, 1M, 2D and 2M.
40133 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40134  
40135       SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40136  
40137 C...Double precision and integer declarations.
40138       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40139       IMPLICIT INTEGER(I-N)
40140       INTEGER PYK,PYCHGE,PYCOMP
40141 C...Commonblocks.
40142       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40143      &XPDIR(-6:6)
40144       COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40145       SAVE /PYINT8/,/PYINT9/
40146 C...Local arrays.
40147       DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
40148 C...Charm and bottom masses (low to compensate for J/psi etc.).
40149       DATA PMC/1.3D0/, PMB/4.6D0/
40150 C...alpha_em and alpha_em/(2*pi).
40151       DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
40152 C...Lambda value for 4 flavours.
40153       DATA ALAM/0.20D0/
40154 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40155       DATA FRACU/0.8D0/
40156 C...VMD couplings f_V**2/(4*pi).
40157       DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
40158 C...Masses for rho (=omega) and phi.
40159       DATA PMRHO/0.770D0/, PMPHI/1.020D0/
40160 C...Number of points in integration for IP2=1.
40161       DATA NSTEP/100/
40162  
40163 C...Reset output.
40164       F2GM=0D0
40165       DO 100 KFL=-6,6
40166         XPDFGM(KFL)=0D0
40167         XPVMD(KFL)=0D0
40168         XPANL(KFL)=0D0
40169         XPANH(KFL)=0D0
40170         XPBEH(KFL)=0D0
40171         XPDIR(KFL)=0D0
40172         VXPVMD(KFL)=0D0
40173         VXPANL(KFL)=0D0
40174         VXPANH(KFL)=0D0
40175         VXPDGM(KFL)=0D0
40176   100 CONTINUE
40177  
40178 C...Set Q0 cut-off parameter as function of set used.
40179       IF(ISET.LE.2) THEN
40180         Q0=0.6D0
40181       ELSE
40182         Q0=2D0
40183       ENDIF
40184       Q02=Q0**2
40185  
40186 C...Scale choice for off-shell photon; common factors.
40187       Q2A=Q2
40188       FACNOR=1D0
40189       IF(IP2.EQ.1) THEN
40190         P2MX=P2+Q02
40191         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40192         FACNOR=LOG(Q2/Q02)/NSTEP
40193       ELSEIF(IP2.EQ.2) THEN
40194         P2MX=MAX(P2,Q02)
40195       ELSEIF(IP2.EQ.3) THEN
40196         P2MX=P2+Q02
40197         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40198       ELSEIF(IP2.EQ.4) THEN
40199         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40200      &  ((Q2+P2)*(Q02+P2)))
40201       ELSEIF(IP2.EQ.5) THEN
40202         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40203      &  ((Q2+P2)*(Q02+P2)))
40204         P2MX=Q0*SQRT(P2MXA)
40205         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40206       ELSEIF(IP2.EQ.6) THEN
40207         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40208      &  ((Q2+P2)*(Q02+P2)))
40209         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40210       ELSE
40211         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40212      &  ((Q2+P2)*(Q02+P2)))
40213         P2MX=Q0*SQRT(P2MXA)
40214         P2MXB=P2MX
40215         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40216         P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
40217         IF(ABS(Q2-Q02).GT.1D-6) THEN
40218           FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40219         ELSEIF(P2.LT.Q02) THEN
40220           FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
40221         ELSE
40222           FACNOR=1D0
40223         ENDIF
40224       ENDIF
40225  
40226 C...Call VMD parametrization for d quark and use to give rho, omega,
40227 C...phi. Note dipole dampening for off-shell photon.
40228       CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40229       XFVAL=VXPGA(1)
40230       XPGA(1)=XPGA(2)
40231       XPGA(-1)=XPGA(-2)
40232       FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40233       FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40234       DO 110 KFL=-5,5
40235         XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40236   110 CONTINUE
40237       XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
40238       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40239       XPVMD(3)=XPVMD(3)+FACS*XFVAL
40240       XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
40241       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40242       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40243       VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
40244       VXPVMD(2)=FRACU*FACUD*XFVAL
40245       VXPVMD(3)=FACS*XFVAL
40246       VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
40247       VXPVMD(-2)=FRACU*FACUD*XFVAL
40248       VXPVMD(-3)=FACS*XFVAL
40249  
40250       IF(IP2.NE.1) THEN
40251 C...Anomalous parametrizations for different strategies
40252 C...for off-shell photons; except full integration.
40253  
40254 C...Call anomalous parametrization for d + u + s.
40255         CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40256         DO 120 KFL=-5,5
40257           XPANL(KFL)=FACNOR*XPGA(KFL)
40258           VXPANL(KFL)=FACNOR*VXPGA(KFL)
40259   120   CONTINUE
40260  
40261 C...Call anomalous parametrization for c and b.
40262         CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40263         DO 130 KFL=-5,5
40264           XPANH(KFL)=FACNOR*XPGA(KFL)
40265           VXPANH(KFL)=FACNOR*VXPGA(KFL)
40266   130   CONTINUE
40267         CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40268         DO 140 KFL=-5,5
40269           XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40270           VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40271   140   CONTINUE
40272  
40273       ELSE
40274 C...Special option: loop over flavours and integrate over k2.
40275         DO 170 KF=1,5
40276           DO 160 ISTEP=1,NSTEP
40277             Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
40278             IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40279      &      (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40280             CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40281             FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40282             IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
40283             IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
40284             DO 150 KFL=-5,5
40285               IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40286               IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40287               IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40288               IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40289   150       CONTINUE
40290   160     CONTINUE
40291   170   CONTINUE
40292       ENDIF
40293  
40294 C...Call Bethe-Heitler term expression for charm and bottom.
40295       CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
40296       XPBEH(4)=XPBH
40297       XPBEH(-4)=XPBH
40298       CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
40299       XPBEH(5)=XPBH
40300       XPBEH(-5)=XPBH
40301  
40302 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40303       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40304         CALL PYGDIR(X,Q2,P2,Q02,XPGA)
40305         DO 180 KFL=-5,5
40306           XPDIR(KFL)=XPGA(KFL)
40307   180   CONTINUE
40308       ENDIF
40309  
40310 C...Store result in output array.
40311       DO 190 KFL=-5,5
40312         CHSQ=1D0/9D0
40313         IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
40314         XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40315         IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40316         XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40317         VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40318   190 CONTINUE
40319  
40320       RETURN
40321       END
40322  
40323 C*********************************************************************
40324  
40325 C...PYGVMD
40326 C...Evaluates the VMD parton distributions of a photon,
40327 C...evolved homogeneously from an initial scale P2 to Q2.
40328 C...Does not include dipole suppression factor.
40329 C...ISET is parton distribution set, see above;
40330 C...additionally ISET=0 is used for the evolution of an anomalous photon
40331 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40332 C...ALAM is the 4-flavour Lambda, which is automatically converted
40333 C...to 3- and 5-flavour equivalents as needed.
40334 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40335  
40336       SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40337  
40338 C...Double precision and integer declarations.
40339       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40340       IMPLICIT INTEGER(I-N)
40341       INTEGER PYK,PYCHGE,PYCOMP
40342 C...Local arrays and data.
40343       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40344       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40345  
40346 C...Reset output.
40347       DO 100 KFL=-6,6
40348         XPGA(KFL)=0D0
40349         VXPGA(KFL)=0D0
40350   100 CONTINUE
40351       KFA=IABS(KF)
40352  
40353 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40354       ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
40355       ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
40356       P2EFF=MAX(P2,1.2D0*ALAM3**2)
40357       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40358       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40359       Q2EFF=MAX(Q2,P2EFF)
40360  
40361 C...Find number of flavours at lower and upper scale.
40362       NFP=4
40363       IF(P2EFF.LT.PMC**2) NFP=3
40364       IF(P2EFF.GT.PMB**2) NFP=5
40365       NFQ=4
40366       IF(Q2EFF.LT.PMC**2) NFQ=3
40367       IF(Q2EFF.GT.PMB**2) NFQ=5
40368  
40369 C...Find s as sum of 3-, 4- and 5-flavour parts.
40370       S=0D0
40371       IF(NFP.EQ.3) THEN
40372         Q2DIV=PMC**2
40373         IF(NFQ.EQ.3) Q2DIV=Q2EFF
40374         S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40375       ENDIF
40376       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40377         P2DIV=P2EFF
40378         IF(NFP.EQ.3) P2DIV=PMC**2
40379         Q2DIV=Q2EFF
40380         IF(NFQ.EQ.5) Q2DIV=PMB**2
40381         S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40382       ENDIF
40383       IF(NFQ.EQ.5) THEN
40384         P2DIV=PMB**2
40385         IF(NFP.EQ.5) P2DIV=P2EFF
40386         S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40387       ENDIF
40388  
40389 C...Calculate frequent combinations of x and s.
40390       X1=1D0-X
40391       XL=-LOG(X)
40392       S2=S**2
40393       S3=S**3
40394       S4=S**4
40395  
40396 C...Evaluate homogeneous anomalous parton distributions below or
40397 C...above threshold.
40398       IF(ISET.EQ.0) THEN
40399         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40400      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40401           XVAL = X * 1.5D0 * (X**2+X1**2)
40402           XGLU = 0D0
40403           XSEA = 0D0
40404         ELSE
40405           XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
40406      &    (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
40407      &    5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
40408      &    X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
40409           XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
40410      &    X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
40411      &    ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
40412           XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
40413      &    X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
40414      &    ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
40415      &    (2D0*X-1D0)*X*XL**2)
40416         ENDIF
40417  
40418 C...Evaluate set 1D parton distributions below or above threshold.
40419       ELSEIF(ISET.EQ.1) THEN
40420         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40421      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40422           XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
40423           XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
40424           XSEA = 0.100D0 * X1**3.76D0
40425         ELSE
40426           XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
40427      &    X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
40428           XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
40429      &    X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
40430      &    XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
40431      &    X**0.40D0 * X1**(1.76D0+3D0*S)
40432           XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
40433      &    (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
40434      &    X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
40435           XSEA0 = 0.100D0 * X1**3.76D0
40436         ENDIF
40437  
40438 C...Evaluate set 1M parton distributions below or above threshold.
40439       ELSEIF(ISET.EQ.2) THEN
40440         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40441      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40442           XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
40443           XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
40444           XSEA = 0D0
40445         ELSE
40446           XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
40447      &    X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
40448           XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
40449      &    EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
40450      &    X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
40451      &    EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
40452           XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
40453      &    X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
40454      &    XL**(2.8D0*S)
40455           XSEA0 = 0D0
40456         ENDIF
40457  
40458 C...Evaluate set 2D parton distributions below or above threshold.
40459       ELSEIF(ISET.EQ.3) THEN
40460         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40461      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40462           XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
40463           XGLU = 1.925D0 * X1**2
40464           XSEA = 0.242D0 * X1**4
40465         ELSE
40466           XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
40467      &    X**(0.46D0+0.25D0*S) *
40468      &    X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
40469      &    (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
40470           XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
40471      &    EXP(-18.67D0*S) *
40472      &    X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
40473      &    * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
40474      &    XL**(9.3D0*S/(1D0+1.7D0*S))
40475           XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
40476      &    (1D0-0.607D0*S+21.95D0*S2) *
40477      &    X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
40478           XSEA0 = 0.242D0 * X1**4
40479         ENDIF
40480  
40481 C...Evaluate set 2M parton distributions below or above threshold.
40482       ELSEIF(ISET.EQ.4) THEN
40483         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40484      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40485           XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
40486           XGLU = 1.808D0 * X1**2
40487           XSEA = 0.209D0 * X1**4
40488         ELSE
40489           XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
40490      &    X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
40491      &    X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
40492      &    XL**(5.15D0*S/(1D0+2D0*S)) +
40493      &    (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
40494           XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
40495      &    X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
40496      &    X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
40497      &    XL**(10.9D0*S/(1D0+2.5D0*S))
40498           XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
40499      &    X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
40500      &    X1**(4D0+S) * XL**(0.45D0*S)
40501           XSEA0 = 0.209D0 * X1**4
40502         ENDIF
40503       ENDIF
40504  
40505 C...Threshold factors for c and b sea.
40506       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40507       XCHM=0D0
40508       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40509         SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40510         IF(ISET.EQ.0) THEN
40511           XCHM=XSEA*(1D0-(SCH/SLL)**2)
40512         ELSE
40513           XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
40514         ENDIF
40515       ENDIF
40516       XBOT=0D0
40517       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40518         SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40519         IF(ISET.EQ.0) THEN
40520           XBOT=XSEA*(1D0-(SBT/SLL)**2)
40521         ELSE
40522           XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
40523         ENDIF
40524       ENDIF
40525  
40526 C...Fill parton distributions.
40527       XPGA(0)=XGLU
40528       XPGA(1)=XSEA
40529       XPGA(2)=XSEA
40530       XPGA(3)=XSEA
40531       XPGA(4)=XCHM
40532       XPGA(5)=XBOT
40533       XPGA(KFA)=XPGA(KFA)+XVAL
40534       DO 110 KFL=1,5
40535         XPGA(-KFL)=XPGA(KFL)
40536   110 CONTINUE
40537       VXPGA(KFA)=XVAL
40538       VXPGA(-KFA)=XVAL
40539  
40540       RETURN
40541       END
40542  
40543 C*********************************************************************
40544  
40545 C...PYGANO
40546 C...Evaluates the parton distributions of the anomalous photon,
40547 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
40548 C...KF=0 gives the sum over (up to) 5 flavours,
40549 C...KF<0 limits to flavours up to abs(KF),
40550 C...KF>0 is for flavour KF only.
40551 C...ALAM is the 4-flavour Lambda, which is automatically converted
40552 C...to 3- and 5-flavour equivalents as needed.
40553 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40554  
40555       SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40556  
40557 C...Double precision and integer declarations.
40558       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40559       IMPLICIT INTEGER(I-N)
40560       INTEGER PYK,PYCHGE,PYCOMP
40561 C...Local arrays and data.
40562       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40563       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40564  
40565 C...Reset output.
40566       DO 100 KFL=-6,6
40567         XPGA(KFL)=0D0
40568         VXPGA(KFL)=0D0
40569   100 CONTINUE
40570       IF(Q2.LE.P2) RETURN
40571       KFA=IABS(KF)
40572  
40573 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40574       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
40575       ALAMSQ(4)=ALAM**2
40576       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
40577       P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
40578       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40579       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40580       Q2EFF=MAX(Q2,P2EFF)
40581       XL=-LOG(X)
40582  
40583 C...Find number of flavours at lower and upper scale.
40584       NFP=4
40585       IF(P2EFF.LT.PMC**2) NFP=3
40586       IF(P2EFF.GT.PMB**2) NFP=5
40587       NFQ=4
40588       IF(Q2EFF.LT.PMC**2) NFQ=3
40589       IF(Q2EFF.GT.PMB**2) NFQ=5
40590  
40591 C...Define range of flavour loop.
40592       IF(KF.EQ.0) THEN
40593         KFLMN=1
40594         KFLMX=5
40595       ELSEIF(KF.LT.0) THEN
40596         KFLMN=1
40597         KFLMX=KFA
40598       ELSE
40599         KFLMN=KFA
40600         KFLMX=KFA
40601       ENDIF
40602  
40603 C...Loop over flavours the photon can branch into.
40604       DO 110 KFL=KFLMN,KFLMX
40605  
40606 C...Light flavours: calculate t range and (approximate) s range.
40607         IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40608           TDIFF=LOG(Q2EFF/P2EFF)
40609           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40610      &    LOG(P2EFF/ALAMSQ(NFQ)))
40611           IF(NFQ.GT.NFP) THEN
40612             Q2DIV=PMB**2
40613             IF(NFQ.EQ.4) Q2DIV=PMC**2
40614             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40615      &      LOG(P2EFF/ALAMSQ(NFQ)))
40616             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40617      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
40618             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40619           ENDIF
40620           IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
40621             Q2DIV=PMC**2
40622             SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
40623      &      LOG(P2EFF/ALAMSQ(4)))
40624             SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
40625      &      LOG(P2EFF/ALAMSQ(3)))
40626             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
40627           ENDIF
40628  
40629 C...u and s quark do not need a separate treatment when d has been done.
40630         ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
40631  
40632 C...Charm: as above, but only include range above c threshold.
40633         ELSEIF(KFL.EQ.4) THEN
40634           IF(Q2.LE.PMC**2) GOTO 110
40635           P2EFF=MAX(P2EFF,PMC**2)
40636           Q2EFF=MAX(Q2EFF,P2EFF)
40637           TDIFF=LOG(Q2EFF/P2EFF)
40638           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40639      &    LOG(P2EFF/ALAMSQ(NFQ)))
40640           IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
40641             Q2DIV=PMB**2
40642             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40643      &      LOG(P2EFF/ALAMSQ(NFQ)))
40644             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40645      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
40646             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40647           ENDIF
40648  
40649 C...Bottom: as above, but only include range above b threshold.
40650         ELSEIF(KFL.EQ.5) THEN
40651           IF(Q2.LE.PMB**2) GOTO 110
40652           P2EFF=MAX(P2EFF,PMB**2)
40653           Q2EFF=MAX(Q2,P2EFF)
40654           TDIFF=LOG(Q2EFF/P2EFF)
40655           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40656      &    LOG(P2EFF/ALAMSQ(NFQ)))
40657         ENDIF
40658  
40659 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
40660         CHSQ=1D0/9D0
40661         IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
40662         FAC=AEM2PI*2D0*CHSQ*TDIFF
40663  
40664 C...Evaluate parton distributions (normalized to unit momentum sum).
40665         IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
40666           XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
40667      &    (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
40668      &    1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
40669      &    X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
40670           XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
40671      &    X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
40672      &    ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
40673           XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
40674      &    X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
40675      &    ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
40676      &    (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
40677  
40678 C...Threshold factors for c and b sea.
40679           SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40680           XCHM=0D0
40681           IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40682             SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40683             XCHM=XSEA*(1D0-(SCH/SLL)**3)
40684           ENDIF
40685           XBOT=0D0
40686           IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40687             SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40688             XBOT=XSEA*(1D0-(SBT/SLL)**3)
40689           ENDIF
40690         ENDIF
40691  
40692 C...Add contribution of each valence flavour.
40693         XPGA(0)=XPGA(0)+FAC*XGLU
40694         XPGA(1)=XPGA(1)+FAC*XSEA
40695         XPGA(2)=XPGA(2)+FAC*XSEA
40696         XPGA(3)=XPGA(3)+FAC*XSEA
40697         XPGA(4)=XPGA(4)+FAC*XCHM
40698         XPGA(5)=XPGA(5)+FAC*XBOT
40699         XPGA(KFL)=XPGA(KFL)+FAC*XVAL
40700         VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
40701   110 CONTINUE
40702       DO 120 KFL=1,5
40703         XPGA(-KFL)=XPGA(KFL)
40704         VXPGA(-KFL)=VXPGA(KFL)
40705   120 CONTINUE
40706  
40707       RETURN
40708       END
40709  
40710  
40711 C*********************************************************************
40712  
40713 C...PYGBEH
40714 C...Evaluates the Bethe-Heitler cross section for heavy flavour
40715 C...production.
40716 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40717  
40718       SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
40719  
40720 C...Double precision and integer declarations.
40721       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40722       IMPLICIT INTEGER(I-N)
40723       INTEGER PYK,PYCHGE,PYCOMP
40724  
40725 C...Local data.
40726       DATA AEM2PI/0.0011614D0/
40727  
40728 C...Reset output.
40729       XPBH=0D0
40730       SIGBH=0D0
40731  
40732 C...Check kinematics limits.
40733       IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
40734       W2=Q2*(1D0-X)/X-P2
40735       BETA2=1D0-4D0*PM2/W2
40736       IF(BETA2.LT.1D-10) RETURN
40737       BETA=SQRT(BETA2)
40738       RMQ=4D0*PM2/Q2
40739  
40740 C...Simple case: P2 = 0.
40741       IF(P2.LT.1D-4) THEN
40742         IF(BETA.LT.0.99D0) THEN
40743           XBL=LOG((1D0+BETA)/(1D0-BETA))
40744         ELSE
40745           XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40746         ENDIF
40747         SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40748      &  XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40749  
40750 C...Complicated case: P2 > 0, based on approximation of
40751 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40752       ELSE
40753         RPQ=1D0-4D0*X**2*P2/Q2
40754         IF(RPQ.GT.1D-10) THEN
40755           RPBE=SQRT(RPQ*BETA2)
40756           IF(RPBE.LT.0.99D0) THEN
40757             XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40758             XBI=2D0*RPBE/(1D0-RPBE**2)
40759           ELSE
40760             RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40761             XBL=LOG((1D0+RPBE)**2/RPBESN)
40762             XBI=2D0*RPBE/RPBESN
40763           ENDIF
40764           SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40765      &    XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40766      &    XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40767         ENDIF
40768       ENDIF
40769  
40770 C...Multiply by charge-squared etc. to get parton distribution.
40771       CHSQ=1D0/9D0
40772       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40773       XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40774  
40775       RETURN
40776       END
40777  
40778 C*********************************************************************
40779  
40780 C...PYGDIR
40781 C...Evaluates the direct contribution, i.e. the C^gamma term,
40782 C...as needed in MSbar parametrizations.
40783 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40784  
40785       SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40786  
40787 C...Double precision and integer declarations.
40788       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40789       IMPLICIT INTEGER(I-N)
40790       INTEGER PYK,PYCHGE,PYCOMP
40791 C...Local array and data.
40792       DIMENSION XPGA(-6:6)
40793       DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40794  
40795 C...Reset output.
40796       DO 100 KFL=-6,6
40797         XPGA(KFL)=0D0
40798   100 CONTINUE
40799  
40800 C...Evaluate common x-dependent expression.
40801       XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40802       CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40803  
40804 C...d, u, s part by simple charge factor.
40805       XPGA(1)=(1D0/9D0)*CGAM
40806       XPGA(2)=(4D0/9D0)*CGAM
40807       XPGA(3)=(1D0/9D0)*CGAM
40808  
40809 C...Also fill for antiquarks.
40810       DO 110 KF=1,5
40811         XPGA(-KF)=XPGA(KF)
40812   110 CONTINUE
40813  
40814       RETURN
40815       END
40816  
40817 C*********************************************************************
40818  
40819 C...PYPDPI
40820 C...Gives pi+ parton distribution according to two different
40821 C...parametrizations.
40822  
40823       SUBROUTINE PYPDPI(X,Q2,XPPI)
40824  
40825 C...Double precision and integer declarations.
40826       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40827       IMPLICIT INTEGER(I-N)
40828       INTEGER PYK,PYCHGE,PYCOMP
40829 C...Commonblocks.
40830       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40831       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40832       COMMON/PYINT1/MINT(400),VINT(400)
40833       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40834 C...Local arrays.
40835       DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40836  
40837 C...The following data lines are coefficients needed in the
40838 C...Owens pion parton distribution parametrizations, see below.
40839 C...Expansion coefficients for up and down valence quark distributions.
40840       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40841      &4.0000D-01,  7.0000D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
40842      &-6.2120D-02,  6.4780D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
40843      &-7.1090D-03,  1.3350D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
40844       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40845      &4.0000D-01,  6.2800D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
40846      &-5.9090D-02,  6.4360D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
40847      &-6.5240D-03,  1.4510D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
40848 C...Expansion coefficients for gluon distribution.
40849       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40850      &8.8800D-01,  0.0000D+00,  3.1100D+00,  6.0000D+00,  0.0000D+00,
40851      &-1.8020D+00, -1.5760D+00, -1.3170D-01,  2.8010D+00, -1.7280D+01,
40852      &1.8120D+00,  1.2000D+00,  5.0680D-01, -1.2160D+01,  2.0490D+01/
40853       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40854      &7.9400D-01,  0.0000D+00,  2.8900D+00,  6.0000D+00,  0.0000D+00,
40855      &-9.1440D-01, -1.2370D+00,  5.9660D-01, -3.6710D+00, -8.1910D+00,
40856      &5.9660D-01,  6.5820D-01, -2.5500D-01, -2.3040D+00,  7.7580D+00/
40857 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40858       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40859      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
40860      &-2.4280D-01, -2.1200D-01,  8.6730D-01,  1.2660D+00,  2.3820D+00,
40861      &1.3860D-01,  3.6710D-03,  4.7470D-02, -2.2150D+00,  3.4820D-01/
40862       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40863      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
40864      &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00,  5.6210D-01,
40865      &-1.7400D-01, -9.6230D-02,  1.5750D+00,  1.3780D+00, -2.7010D-01/
40866 C...Expansion coefficients for charm quark sea distribution.
40867       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40868      &0.0000D+00, -2.2120D-02,  2.8940D+00,  0.0000D+00,  0.0000D+00,
40869      &7.9280D-02, -3.7850D-01,  9.4330D+00,  5.2480D+00,  8.3880D+00,
40870      &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40871       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40872      &0.0000D+00, -8.8200D-02,  1.9240D+00,  0.0000D+00,  0.0000D+00,
40873      &6.2290D-02, -2.8920D-01,  2.4240D-01, -4.4630D+00, -8.3670D-01,
40874      &-4.0990D-02, -1.0820D-01,  2.0360D+00,  5.2090D+00, -4.8400D-02/
40875  
40876 C...Euler's beta function, requires ordinary Gamma function
40877       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40878  
40879 C...Reset output array.
40880       DO 100 KFL=-6,6
40881         XPPI(KFL)=0D0
40882   100 CONTINUE
40883  
40884       IF(MSTP(53).LE.2) THEN
40885 C...Pion parton distributions from Owens.
40886 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40887  
40888 C...Determine set, Lambda and s expansion variable.
40889         NSET=MSTP(53)
40890         IF(NSET.EQ.1) ALAM=0.2D0
40891         IF(NSET.EQ.2) ALAM=0.4D0
40892         VINT(231)=4D0
40893         IF(MSTP(57).LE.0) THEN
40894           SD=0D0
40895         ELSE
40896           Q2IN=MIN(2D3,MAX(4D0,Q2))
40897           SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40898         ENDIF
40899  
40900 C...Calculate parton distributions.
40901         DO 120 KFL=1,4
40902           DO 110 IS=1,5
40903             TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40904      &      COW(3,IS,KFL,NSET)*SD**2
40905   110     CONTINUE
40906           IF(KFL.EQ.1) THEN
40907             XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40908           ELSE
40909             XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40910      &      TS(5)*X**2)
40911           ENDIF
40912   120   CONTINUE
40913  
40914 C...Put into output array.
40915         XPPI(0)=XQ(2)
40916         XPPI(1)=XQ(3)/6D0
40917         XPPI(2)=XQ(1)+XQ(3)/6D0
40918         XPPI(3)=XQ(3)/6D0
40919         XPPI(4)=XQ(4)
40920         XPPI(-1)=XQ(1)+XQ(3)/6D0
40921         XPPI(-2)=XQ(3)/6D0
40922         XPPI(-3)=XQ(3)/6D0
40923         XPPI(-4)=XQ(4)
40924  
40925 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40926 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40927 C...10^-5 < x < 1.
40928       ELSE
40929  
40930 C...Determine s expansion variable and some x expressions.
40931         VINT(231)=0.25D0
40932         IF(MSTP(57).LE.0) THEN
40933           SD=0D0
40934         ELSE
40935           Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40936           SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40937         ENDIF
40938         SD2=SD**2
40939         XL=-LOG(X)
40940         XS=SQRT(X)
40941  
40942 C...Evaluate valence, gluon and sea distributions.
40943         XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40944      &  (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40945         XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40946      &  SD-0.175D0*SD2)+
40947      &  (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40948      &  SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40949      &  XL)))*
40950      &  (1D0-X)**(0.390D0+1.053D0*SD)
40951         XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40952      &  X)**3.359D0*
40953      &  EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40954      &  XL))/
40955      &  XL**(2.538D0-0.763D0*SD)
40956         IF(SD.LE.0.888D0) THEN
40957           XFCHM=0D0
40958         ELSE
40959           XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40960      &    0.771D0*SD)*
40961      &    EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40962      &    XL))
40963         ENDIF
40964         IF(SD.LE.1.351D0) THEN
40965           XFBOT=0D0
40966         ELSE
40967           XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40968      &    EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40969      &    XL))
40970         ENDIF
40971  
40972 C...Put into output array.
40973         XPPI(0)=XFGLU
40974         XPPI(1)=XFSEA
40975         XPPI(2)=XFSEA
40976         XPPI(3)=XFSEA
40977         XPPI(4)=XFCHM
40978         XPPI(5)=XFBOT
40979         DO 130 KFL=1,5
40980           XPPI(-KFL)=XPPI(KFL)
40981   130   CONTINUE
40982         XPPI(2)=XPPI(2)+XFVAL
40983         XPPI(-1)=XPPI(-1)+XFVAL
40984       ENDIF
40985  
40986       RETURN
40987       END
40988  
40989 C*********************************************************************
40990  
40991 C...PYPDPR
40992 C...Gives proton parton distributions according to a few different
40993 C...parametrizations.
40994  
40995       SUBROUTINE PYPDPR(X,Q2,XPPR)
40996  
40997 C...Double precision and integer declarations.
40998       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40999       IMPLICIT INTEGER(I-N)
41000       INTEGER PYK,PYCHGE,PYCOMP
41001 C...Commonblocks.
41002       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41003       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41004       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41005       COMMON/PYINT1/MINT(400),VINT(400)
41006       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41007 C...Arrays and data.
41008       DIMENSION XPPR(-6:6),Q2MIN(16)
41009       DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
41010      &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
41011  
41012 C...Reset output array.
41013       DO 100 KFL=-6,6
41014         XPPR(KFL)=0D0
41015   100 CONTINUE
41016  
41017 C...Common preliminaries.
41018       NSET=MAX(1,MIN(16,MSTP(51)))
41019       IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
41020       VINT(231)=Q2MIN(NSET)
41021       IF(MSTP(57).EQ.0) THEN
41022         Q2L=Q2MIN(NSET)
41023       ELSE
41024         Q2L=MAX(Q2MIN(NSET),Q2)
41025       ENDIF
41026  
41027       IF(NSET.GE.1.AND.NSET.LE.3) THEN
41028 C...Interface to the CTEQ 3 parton distributions.
41029         QRT=SQRT(MAX(1D0,Q2L))
41030  
41031 C...Loop over flavours.
41032         DO 110 I=-6,6
41033           IF(I.LE.0) THEN
41034             XPPR(I)=PYCTEQ(NSET,I,X,QRT)
41035           ELSEIF(I.LE.2) THEN
41036             XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
41037           ELSE
41038             XPPR(I)=XPPR(-I)
41039           ENDIF
41040   110   CONTINUE
41041  
41042       ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
41043 C...Interface to the GRV 94 distributions.
41044         IF(NSET.EQ.4) THEN
41045           CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41046         ELSEIF(NSET.EQ.5) THEN
41047           CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41048         ELSE
41049           CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41050         ENDIF
41051  
41052 C...Put into output array.
41053         XPPR(0)=GL
41054         XPPR(-1)=0.5D0*(UDB+DEL)
41055         XPPR(-2)=0.5D0*(UDB-DEL)
41056         XPPR(-3)=SB
41057         XPPR(-4)=CHM
41058         XPPR(-5)=BOT
41059         XPPR(1)=DV+XPPR(-1)
41060         XPPR(2)=UV+XPPR(-2)
41061         XPPR(3)=SB
41062         XPPR(4)=CHM
41063         XPPR(5)=BOT
41064  
41065       ELSEIF(NSET.EQ.7) THEN
41066 C...Interface to the CTEQ 5L parton distributions.
41067 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
41068 C...freezing x*f(x,Q2) at borders.
41069         QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41070         XIN=MAX(1D-6,MIN(1D0,X))
41071  
41072 C...Loop over flavours (with u <-> d notation mismatch).
41073         SUMUDB=PYCT5L(-1,XIN,QRT)
41074         RATUDB=PYCT5L(-2,XIN,QRT)
41075         DO 120 I=-5,2
41076           IF(I.EQ.1) THEN
41077             XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
41078           ELSEIF(I.EQ.2) THEN
41079             XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
41080           ELSEIF(I.EQ.-1) THEN
41081             XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41082           ELSEIF(I.EQ.-2) THEN
41083             XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41084           ELSE
41085             XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
41086             IF(I.LT.0) XPPR(-I)=XPPR(I)
41087           ENDIF
41088   120   CONTINUE
41089  
41090       ELSEIF(NSET.EQ.8) THEN
41091 C...Interface to the CTEQ 5M1 parton distributions.
41092         QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41093         XIN=MAX(1D-6,MIN(1D0,X))
41094  
41095 C...Loop over flavours (with u <-> d notation mismatch).
41096         SUMUDB=PYCT5M(-1,XIN,QRT)
41097         RATUDB=PYCT5M(-2,XIN,QRT)
41098         DO 130 I=-5,2
41099           IF(I.EQ.1) THEN
41100             XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
41101           ELSEIF(I.EQ.2) THEN
41102             XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
41103           ELSEIF(I.EQ.-1) THEN
41104             XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41105           ELSEIF(I.EQ.-2) THEN
41106             XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41107           ELSE
41108             XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
41109             IF(I.LT.0) XPPR(-I)=XPPR(I)
41110           ENDIF
41111   130   CONTINUE
41112  
41113       ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
41114 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
41115 C...obsolete but offers backwards compatibility.
41116         CALL PYPDPO(X,Q2L,XPPR)
41117  
41118 C...Symmetric choice for debugging only
41119       ELSEIF(NSET.EQ.16) THEN
41120         XPPR(0)=.5D0/X
41121         XPPR(1)=.05D0/X
41122         XPPR(2)=.05D0/X
41123         XPPR(3)=.05D0/X
41124         XPPR(4)=.05D0/X
41125         XPPR(5)=.05D0/X
41126         XPPR(-1)=.05D0/X
41127         XPPR(-2)=.05D0/X
41128         XPPR(-3)=.05D0/X
41129         XPPR(-4)=.05D0/X
41130         XPPR(-5)=.05D0/X
41131  
41132       ENDIF
41133  
41134       RETURN
41135       END
41136  
41137 C*********************************************************************
41138  
41139 C...PYCTEQ
41140 C...Gives the CTEQ 3 parton distribution function sets in
41141 C...parametrized form, of October 24, 1994.
41142 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
41143 C...J. Qiu, W.K. Tung and H. Weerts.
41144  
41145       FUNCTION PYCTEQ (ISET, IPRT, X, Q)
41146  
41147 C...Double precision declaration.
41148       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41149       IMPLICIT INTEGER(I-N)
41150  
41151 C...Data on Lambda values of fits, minimum Q and quark masses.
41152       DIMENSION ALM(3), QMS(4:6)
41153       DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
41154       DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
41155  
41156 C....Check flavour thresholds. Set up QI for SB.
41157       IP = IABS(IPRT)
41158       IF(IP .GE. 4) THEN
41159         IF(Q .LE. QMS(IP)) THEN
41160           PYCTEQ = 0D0
41161           RETURN
41162         ENDIF
41163         QI = QMS(IP)
41164       ELSE
41165         QI = QMN
41166       ENDIF
41167  
41168 C...Use "standard lambda" of parametrization program for expansion.
41169       ALAM = ALM (ISET)
41170       SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
41171       SB = LOG (SBL)
41172       SB2 = SB*SB
41173       SB3 = SB2*SB
41174  
41175 C...Expansion for CTEQ3L.
41176       IF(ISET .EQ. 1) THEN
41177         IF(IPRT .EQ. 2) THEN
41178           A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
41179      &    0.3171D+00*SB3)
41180           A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
41181           A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
41182           A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
41183           A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
41184           A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
41185         ELSEIF(IPRT .EQ. 1) THEN
41186           A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
41187      &    0.7728D+00*SB3)
41188           A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
41189           A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
41190           A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
41191           A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
41192           A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
41193         ELSEIF(IPRT .EQ. 0) THEN
41194           A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
41195      &    0.5343D+00*SB3)
41196           A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
41197           A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
41198           A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
41199           A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
41200           A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
41201         ELSEIF(IPRT .EQ. -1) THEN
41202           A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
41203      &    0.2031D+01*SB3)
41204           A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
41205           A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
41206           A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
41207           A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
41208           A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
41209         ELSEIF(IPRT .EQ. -2) THEN
41210           A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
41211      &    0.9872D-01*SB3)
41212           A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
41213           A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
41214           A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
41215           A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
41216           A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
41217         ELSEIF(IPRT .EQ. -3) THEN
41218           A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
41219      &    0.8390D+00*SB3)
41220           A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
41221           A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
41222           A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
41223           A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
41224           A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
41225         ELSEIF(IPRT .EQ. -4) THEN
41226           A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
41227      &    0.1651D-01*SB2)
41228           A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
41229           A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
41230           A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
41231           A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
41232           A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
41233         ELSEIF(IPRT .EQ. -5) THEN
41234           A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
41235      &    0.3702D+01*SB2)
41236           A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
41237           A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
41238           A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
41239           A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
41240           A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
41241         ELSEIF(IPRT .EQ. -6) THEN
41242           A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
41243      &    0.6943D+00*SB2)
41244           A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
41245           A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
41246           A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
41247           A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
41248           A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
41249         ENDIF
41250  
41251 C...Expansion for CTEQ3M.
41252       ELSEIF(ISET .EQ. 2) THEN
41253         IF(IPRT .EQ. 2) THEN
41254           A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
41255      &    0.2935D+00*SB3)
41256           A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
41257           A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
41258           A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
41259           A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
41260           A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
41261         ELSEIF(IPRT .EQ. 1) THEN
41262           A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
41263      &    0.4305D-01*SB3)
41264           A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
41265           A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
41266           A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
41267           A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
41268           A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
41269         ELSEIF(IPRT .EQ. 0) THEN
41270           A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
41271      &    0.1037D-01*SB3)
41272           A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
41273           A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
41274           A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
41275           A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
41276           A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
41277         ELSEIF(IPRT .EQ. -1) THEN
41278           A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
41279      &    0.1602D+01*SB3)
41280           A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
41281           A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
41282           A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
41283           A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
41284           A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
41285         ELSEIF(IPRT .EQ. -2) THEN
41286           A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
41287      &    0.2496D+00*SB3)
41288           A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
41289           A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
41290           A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
41291           A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
41292           A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
41293         ELSEIF(IPRT .EQ. -3) THEN
41294           A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
41295      &    0.1936D+01*SB3)
41296           A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
41297           A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
41298           A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
41299           A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
41300           A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
41301         ELSEIF(IPRT .EQ. -4) THEN
41302           A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
41303      &    0.5348D+00*SB2)
41304           A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
41305           A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
41306           A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
41307           A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
41308           A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
41309         ELSEIF(IPRT .EQ. -5) THEN
41310           A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
41311      &    0.1569D+01*SB2)
41312           A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
41313           A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
41314           A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
41315           A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
41316           A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
41317         ELSEIF(IPRT .EQ. -6) THEN
41318           A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
41319      &    0.8838D+01*SB2)
41320           A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
41321           A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
41322           A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
41323           A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
41324           A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
41325         ENDIF
41326  
41327 C...Expansion for CTEQ3D.
41328       ELSEIF(ISET .EQ. 3) THEN
41329         IF(IPRT .EQ. 2) THEN
41330           A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
41331      &    0.2902D+00*SB3)
41332           A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
41333           A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
41334           A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
41335           A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
41336           A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
41337         ELSEIF(IPRT .EQ. 1) THEN
41338           A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
41339      &    0.7257D+00*SB3)
41340           A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
41341           A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
41342           A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
41343           A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
41344           A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
41345         ELSEIF(IPRT .EQ. 0) THEN
41346           A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
41347      &    0.2734D-04*SB3)
41348           A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
41349           A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
41350           A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
41351           A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
41352           A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
41353         ELSEIF(IPRT .EQ. -1) THEN
41354           A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
41355      &    0.1671D+01*SB3)
41356           A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
41357           A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
41358           A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
41359           A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
41360           A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
41361         ELSEIF(IPRT .EQ. -2) THEN
41362           A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
41363      &    0.2223D+00*SB3)
41364           A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
41365           A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
41366           A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
41367           A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
41368           A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
41369         ELSEIF(IPRT .EQ. -3) THEN
41370           A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
41371      &    0.1937D+01*SB3)
41372           A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
41373           A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
41374           A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
41375           A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
41376           A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
41377         ELSEIF(IPRT .EQ. -4) THEN
41378           A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
41379      &    0.5137D+00*SB2)
41380           A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
41381           A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
41382           A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
41383           A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
41384           A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
41385         ELSEIF(IPRT .EQ. -5) THEN
41386           A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
41387      &    0.2143D+01*SB2)
41388           A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
41389           A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
41390           A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
41391           A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
41392           A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
41393         ELSEIF(IPRT .EQ. -6) THEN
41394           A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
41395      &    0.9998D+01*SB2)
41396           A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
41397           A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
41398           A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
41399           A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
41400           A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
41401         ENDIF
41402       ENDIF
41403  
41404 C...Calculation of x * f(x, Q).
41405       PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
41406      &   *(LOG(1D0+1D0/X))**A5 )
41407  
41408       RETURN
41409       END
41410  
41411 C*********************************************************************
41412  
41413 C...PYGRVL
41414 C...Gives the GRV 94 L (leading order) parton distribution function set
41415 C...in parametrized form.
41416 C...Authors: M. Glueck, E. Reya and A. Vogt.
41417  
41418       SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41419  
41420 C...Double precision declaration.
41421       IMPLICIT DOUBLE PRECISION (A - Z)
41422  
41423 C...Common expressions.
41424       MU2  = 0.23D0
41425       LAM2 = 0.2322D0 * 0.2322D0
41426       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41427       DS = SQRT (S)
41428       S2 = S * S
41429       S3 = S2 * S
41430  
41431 C...uv :
41432       NU  =  2.284D0 + 0.802D0 * S + 0.055D0 * S2
41433       AKU =  0.590D0 - 0.024D0 * S
41434       BKU =  0.131D0 + 0.063D0 * S
41435       AU  = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
41436       BU  =  0.213D0 + 2.669D0 * S - 0.728D0 * S2
41437       CU  =  8.854D0 - 9.135D0 * S + 1.979D0 * S2
41438       DU  =  2.997D0 + 0.753D0 * S - 0.076D0 * S2
41439       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41440  
41441 C...dv :
41442       ND  =  0.371D0 + 0.083D0 * S + 0.039D0 * S2
41443       AKD =  0.376D0
41444       BKD =  0.486D0 + 0.062D0 * S
41445       AD  = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
41446       BD  =  12.41D0 - 10.52D0 * S + 2.267D0 * S2
41447       CD  =  6.373D0 - 6.208D0 * S + 1.418D0 * S2
41448       DD  =  3.691D0 + 0.799D0 * S - 0.071D0 * S2
41449       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41450  
41451 C...del :
41452       NE  =  0.082D0 + 0.014D0 * S + 0.008D0 * S2
41453       AKE =  0.409D0 - 0.005D0 * S
41454       BKE =  0.799D0 + 0.071D0 * S
41455       AE  = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
41456       BE  =  90.31D0 - 74.15D0 * S + 7.645D0 * S2
41457       CE  =  0.0D0
41458       DE  =  7.486D0 + 1.217D0 * S - 0.159D0 * S2
41459       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41460  
41461 C...udb :
41462       ALX =  1.451D0
41463       BEX =  0.271D0
41464       AKX =  0.410D0 - 0.232D0 * S
41465       BKX =  0.534D0 - 0.457D0 * S
41466       AGX =  0.890D0 - 0.140D0 * S
41467       BGX = -0.981D0
41468       CX  =  0.320D0 + 0.683D0 * S
41469       DX  =  4.752D0 + 1.164D0 * S + 0.286D0 * S2
41470       EX  =  4.119D0 + 1.713D0 * S
41471       ESX =  0.682D0 + 2.978D0 * S
41472       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41473      & DX, EX, ESX)
41474  
41475 C...sb :
41476       STS =  0D0
41477       ALS =  0.914D0
41478       BES =  0.577D0
41479       AKS =  1.798D0 - 0.596D0 * S
41480       AS  = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
41481       BS  =  18.92D0 - 16.73D0 * DS + 5.168D0 * S
41482       DST =  6.379D0 - 0.350D0 * S  + 0.142D0 * S2
41483       EST =  3.981D0 + 1.638D0 * S
41484       ESS =  6.402D0
41485       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41486  
41487 C...cb :
41488       STC =  0.888D0
41489       ALC =  1.01D0
41490       BEC =  0.37D0
41491       AKC =  0D0
41492       AC  =  0D0
41493       BC  =  4.24D0  - 0.804D0 * S
41494       DCT =  3.46D0  - 1.076D0 * S
41495       ECT =  4.61D0  + 1.49D0  * S
41496       ESC =  2.555D0 + 1.961D0 * S
41497       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41498  
41499 C...bb :
41500       STB =  1.351D0
41501       ALB =  1.00D0
41502       BEB =  0.51D0
41503       AKB =  0D0
41504       AB  =  0D0
41505       BB  =  1.848D0
41506       DBT =  2.929D0 + 1.396D0 * S
41507       EBT =  4.71D0  + 1.514D0 * S
41508       ESB =  4.02D0  + 1.239D0 * S
41509       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41510  
41511 C...gl :
41512       ALG =  0.524D0
41513       BEG =  1.088D0
41514       AKG =  1.742D0 - 0.930D0 * S
41515       BKG =                         - 0.399D0 * S2
41516       AG  =  7.486D0 - 2.185D0 * S
41517       BG  =  16.69D0 - 22.74D0 * S  + 5.779D0 * S2
41518       CG  = -25.59D0 + 29.71D0 * S  - 7.296D0 * S2
41519       DG  =  2.792D0 + 2.215D0 * S  + 0.422D0 * S2 - 0.104D0 * S3
41520       EG  =  0.807D0 + 2.005D0 * S
41521       ESG =  3.841D0 + 0.316D0 * S
41522       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
41523      & DG, EG, ESG)
41524  
41525       RETURN
41526       END
41527  
41528 C*********************************************************************
41529  
41530 C...PYGRVM
41531 C...Gives the GRV 94 M (MSbar) parton distribution function set
41532 C...in parametrized form.
41533 C...Authors: M. Glueck, E. Reya and A. Vogt.
41534  
41535       SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41536  
41537 C...Double precision declaration.
41538       IMPLICIT DOUBLE PRECISION (A - Z)
41539  
41540 C...Common expressions.
41541       MU2  = 0.34D0
41542       LAM2 = 0.248D0 * 0.248D0
41543       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41544       DS = SQRT (S)
41545       S2 = S * S
41546       S3 = S2 * S
41547  
41548 C...uv :
41549       NU  =  1.304D0 + 0.863D0 * S
41550       AKU =  0.558D0 - 0.020D0 * S
41551       BKU =          0.183D0 * S
41552       AU  = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
41553       BU  =  6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
41554       CU  =  7.771D0 - 10.09D0 * S + 2.630D0 * S2
41555       DU  =  3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
41556       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41557  
41558 C...dv :
41559       ND  =  0.102D0 - 0.017D0 * S + 0.005D0 * S2
41560       AKD =  0.270D0 - 0.019D0 * S
41561       BKD =  0.260D0
41562       AD  =  2.393D0 + 6.228D0 * S - 0.881D0 * S2
41563       BD  =  46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
41564       CD  =  17.83D0 - 53.47D0 * S + 21.24D0 * S2
41565       DD  =  4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
41566       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41567  
41568 C...del :
41569       NE  =  0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
41570       AKE =  0.409D0 - 0.007D0 * S
41571       BKE =  0.782D0 + 0.082D0 * S
41572       AE  = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
41573       BE  =  90.20D0 - 74.97D0 * S + 4.526D0 * S2
41574       CE  =  0.0D0
41575       DE  =  8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
41576       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41577  
41578 C...udb :
41579       ALX =  0.877D0
41580       BEX =  0.561D0
41581       AKX =  0.275D0
41582       BKX =  0.0D0
41583       AGX =  0.997D0
41584       BGX =  3.210D0 - 1.866D0 * S
41585       CX  =  7.300D0
41586       DX  =  9.010D0 + 0.896D0 * DS + 0.222D0 * S2
41587       EX  =  3.077D0 + 1.446D0 * S
41588       ESX =  3.173D0 - 2.445D0 * DS + 2.207D0 * S
41589       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41590      & DX, EX, ESX)
41591  
41592 C...sb :
41593       STS =  0D0
41594       ALS =  0.756D0
41595       BES =  0.216D0
41596       AKS =  1.690D0 + 0.650D0 * DS - 0.922D0 * S
41597       AS  = -4.329D0 + 1.131D0 * S
41598       BS  =  9.568D0 - 1.744D0 * S
41599       DST =  9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
41600       EST =  3.031D0 + 1.639D0 * S
41601       ESS =  5.837D0 + 0.815D0 * S
41602       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41603  
41604 C...cb :
41605       STC =  0.820D0
41606       ALC =  0.98D0
41607       BEC =  0D0
41608       AKC = -0.625D0 - 0.523D0 * S
41609       AC  =  0D0
41610       BC  =  1.896D0 + 1.616D0 * S
41611       DCT =  4.12D0  + 0.683D0 * S
41612       ECT =  4.36D0  + 1.328D0 * S
41613       ESC =  0.677D0 + 0.679D0 * S
41614       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41615  
41616 C...bb :
41617       STB =  1.297D0
41618       ALB =  0.99D0
41619       BEB =  0D0
41620       AKB =          - 0.193D0 * S
41621       AB  =  0D0
41622       BB  =  0D0
41623       DBT =  3.447D0 + 0.927D0 * S
41624       EBT =  4.68D0  + 1.259D0 * S
41625       ESB =  1.892D0 + 2.199D0 * S
41626       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41627  
41628 C...gl :
41629        ALG =  1.014D0
41630        BEG =  1.738D0
41631        AKG =  1.724D0 + 0.157D0 * S
41632        BKG =  0.800D0 + 1.016D0 * S
41633        AG  =  7.517D0 - 2.547D0 * S
41634        BG  =  34.09D0 - 52.21D0 * DS + 17.47D0 * S
41635        CG  =  4.039D0 + 1.491D0 * S
41636        DG  =  3.404D0 + 0.830D0 * S
41637        EG  = -1.112D0 + 3.438D0 * S  - 0.302D0 * S2
41638        ESG =  3.256D0 - 0.436D0 * S
41639        GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41640  
41641        RETURN
41642        END
41643  
41644 C*********************************************************************
41645  
41646 C...PYGRVD
41647 C...Gives the GRV 94 D (DIS) parton distribution function set
41648 C...in parametrized form.
41649 C...Authors: M. Glueck, E. Reya and A. Vogt.
41650  
41651       SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41652  
41653 C...Double precision declaration.
41654       IMPLICIT DOUBLE PRECISION (A - Z)
41655  
41656 C...Common expressions.
41657       MU2  = 0.34D0
41658       LAM2 = 0.248D0 * 0.248D0
41659       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41660       DS = SQRT (S)
41661       S2 = S * S
41662       S3 = S2 * S
41663  
41664 C...uv :
41665       NU  =  2.484D0 + 0.116D0 * S + 0.093D0 * S2
41666       AKU =  0.563D0 - 0.025D0 * S
41667       BKU =  0.054D0 + 0.154D0 * S
41668       AU  = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
41669       BU  = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
41670       CU  =  11.52D0 - 12.99D0 * S + 3.161D0 * S2
41671       DU  =  2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
41672       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41673  
41674 C...dv :
41675       ND  =  0.156D0 - 0.017D0 * S
41676       AKD =  0.299D0 - 0.022D0 * S
41677       BKD =  0.259D0 - 0.015D0 * S
41678       AD  =  3.445D0 + 1.278D0 * S + 0.326D0 * S2
41679       BD  = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
41680       CD  =  55.45D0 - 69.92D0 * S + 20.78D0 * S2
41681       DD  =  3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
41682       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41683  
41684 C...del :
41685       NE  =  0.099D0 + 0.019D0 * S + 0.002D0 * S2
41686       AKE =  0.419D0 - 0.013D0 * S
41687       BKE =  1.064D0 - 0.038D0 * S
41688       AE  = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
41689       BE  =  28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
41690       CE  =  84.57D0 - 108.8D0 * S + 31.52D0 * S2
41691       DE  =  7.469D0 + 2.480D0 * S - 0.866D0 * S2
41692       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41693  
41694 C...udb :
41695       ALX =  1.215D0
41696       BEX =  0.466D0
41697       AKX =  0.326D0 + 0.150D0 * S
41698       BKX =  0.956D0 + 0.405D0 * S
41699       AGX =  0.272D0
41700       BGX =  3.794D0 - 2.359D0 * DS
41701       CX  =  2.014D0
41702       DX  =  7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
41703       EX  =  3.049D0 + 1.597D0 * S
41704       ESX =  4.396D0 - 4.594D0 * DS + 3.268D0 * S
41705       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41706      & DX, EX, ESX)
41707  
41708 C...sb :
41709       STS =  0D0
41710       ALS =  0.175D0
41711       BES =  0.344D0
41712       AKS =  1.415D0 - 0.641D0 * DS
41713       AS  =  0.580D0 - 9.763D0 * DS + 6.795D0 * S  - 0.558D0 * S2
41714       BS  =  5.617D0 + 5.709D0 * DS - 3.972D0 * S
41715       DST =  13.78D0 - 9.581D0 * S  + 5.370D0 * S2 - 0.996D0 * S3
41716       EST =  4.546D0 + 0.372D0 * S2
41717       ESS =  5.053D0 - 1.070D0 * S  + 0.805D0 * S2
41718       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41719  
41720 C...cb :
41721       STC =  0.820D0
41722       ALC =  0.98D0
41723       BEC =  0D0
41724       AKC = -0.625D0 - 0.523D0 * S
41725       AC  =  0D0
41726       BC  =  1.896D0 + 1.616D0 * S
41727       DCT =  4.12D0  + 0.683D0 * S
41728       ECT =  4.36D0  + 1.328D0 * S
41729       ESC =  0.677D0 + 0.679D0 * S
41730       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41731  
41732 C...bb :
41733       STB =  1.297D0
41734       ALB =  0.99D0
41735       BEB =  0D0
41736       AKB =          - 0.193D0 * S
41737       AB  =  0D0
41738       BB  =  0D0
41739       DBT =  3.447D0 + 0.927D0 * S
41740       EBT =  4.68D0  + 1.259D0 * S
41741       ESB =  1.892D0 + 2.199D0 * S
41742       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41743  
41744 C...gl :
41745       ALG =  1.258D0
41746       BEG =  1.846D0
41747       AKG =  2.423D0
41748       BKG =  2.427D0 + 1.311D0 * S  - 0.153D0 * S2
41749       AG  =  25.09D0 - 7.935D0 * S
41750       BG  = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41751       CG  =  590.3D0 - 173.8D0 * S
41752       DG  =  5.196D0 + 1.857D0 * S
41753       EG  = -1.648D0 + 3.988D0 * S  - 0.432D0 * S2
41754       ESG =  3.232D0 - 0.542D0 * S
41755       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41756  
41757       RETURN
41758       END
41759  
41760 C*********************************************************************
41761  
41762 C...PYGRVV
41763 C...Auxiliary for the GRV 94 parton distribution functions
41764 C...for u and d valence and d-u sea.
41765 C...Authors: M. Glueck, E. Reya and A. Vogt.
41766  
41767       FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41768  
41769 C...Double precision declaration.
41770       IMPLICIT DOUBLE PRECISION (A - Z)
41771  
41772 C...Evaluation.
41773       DX = SQRT (X)
41774       PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41775      & (1D0- X)**D
41776  
41777       RETURN
41778       END
41779  
41780 C*********************************************************************
41781  
41782 C...PYGRVW
41783 C...Auxiliary for the GRV 94 parton distribution functions
41784 C...for d+u sea and gluon.
41785 C...Authors: M. Glueck, E. Reya and A. Vogt.
41786  
41787       FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41788  
41789 C...Double precision declaration.
41790       IMPLICIT DOUBLE PRECISION (A - Z)
41791  
41792 C...Evaluation.
41793       LX = LOG (1D0/X)
41794       PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41795      &     * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41796  
41797       RETURN
41798       END
41799  
41800 C*********************************************************************
41801  
41802 C...PYGRVS
41803 C...Auxiliary for the GRV 94 parton distribution functions
41804 C...for s, c and b sea.
41805 C...Authors: M. Glueck, E. Reya and A. Vogt.
41806  
41807       FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41808  
41809 C...Double precision declaration.
41810       IMPLICIT DOUBLE PRECISION (A - Z)
41811  
41812 C...Evaluation.
41813       IF(S.LE.STH) THEN
41814         PYGRVS = 0D0
41815       ELSE
41816         DX = SQRT (X)
41817         LX = LOG (1D0/X)
41818         PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41819      &     (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41820       ENDIF
41821  
41822       RETURN
41823       END
41824  
41825 C*********************************************************************
41826  
41827 C...PYCT5L
41828 C...Auxiliary function for parametrization of CTEQ5L.
41829 C...Author: J. Pumplin 9/99.
41830  
41831 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41832 C...in Parametrized Form
41833 C...            September 15, 1999
41834 C
41835 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41836 C...      CTEQ5 PPARTON DISTRIBUTIONS"
41837 C...hep-ph/9903282
41838  
41839 C...The CTEQ5M1 set given here is an updated version of the original
41840 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41841 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41842 C...almost all applications.
41843 C...The improvement is in the QCD evolution which is now more
41844 C...accurate, and which agrees completely with the benchmark work
41845 C...of the HERA 96/97 Workshop.
41846 C...The differences between the parametrized and the corresponding
41847 C...table versions (on which it is based) are of similar order as
41848 C...between the two version.
41849  
41850 C...!! Because accurate parametrizations over a wide range of (x,Q)
41851 C...is hard to obtain, only the most widely used sets CTEQ5M and
41852 C...CTEQ5L are available in parametrized form for now.
41853  
41854 C...These parametrizations were obtained by Jon Pumplin.
41855  
41856 C  Iset   PDF        Description              Alpha_s(Mz)  Lam4  Lam5
41857 C -------------------------------------------------------------------
41858 C   1    CTEQ5M1  Standard NLO MSbar scheme      0.118     326   226
41859 C   3    CTEQ5L   Leading Order                  0.127     192   146
41860 C -------------------------------------------------------------------
41861 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41862 C...order form of Alpha_s!!  Alpha_s(Mz) gives the absolute
41863 C...calibration.
41864  
41865 C...The two Iset value are adopted to agree with the standard table
41866 C...versions.
41867  
41868 C...Range of validity:
41869 C...The range of (x, Q) covered by this parametrization of the QCD
41870 C...evolved parton distributions is 1E-6 < x < 1 ;
41871 C...1.1 GeV < Q < 10 TeV.  Of course, the PDFs are constrained by
41872 C...data only in a subset of that region; and the assumed DGLAP
41873 C...evolution is unlikely to be valid for all of it either.
41874  
41875 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41876 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41877 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41878 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41879  
41880       FUNCTION PYCT5L(IFL,X,Q)
41881  
41882 C...Double precision declaration.
41883       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41884       IMPLICIT INTEGER(I-N)
41885  
41886       PARAMETER (NEX=8, NLF=2)
41887       DIMENSION AM(0:NEX,0:NLF,-5:2)
41888       DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41889       DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41890       DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41891       DIMENSION AF(0:NEX)
41892  
41893       DATA MEXVEC( 2) / 8 /
41894       DATA MLFVEC( 2) / 2 /
41895       DATA UT1VEC( 2) /  0.4971265E+01 /
41896       DATA UT2VEC( 2) / -0.1105128E+01 /
41897       DATA ALFVEC( 2) /  0.2987216E+00 /
41898       DATA QMAVEC( 2) /  0.0000000E+00 /
41899       DATA (AM( 0,K, 2),K=0, 2)
41900      & /  0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41901       DATA (AM( 1,K, 2),K=0, 2)
41902      & /  0.9714424E+00,  0.1011827E-01, -0.1023660E-01 /
41903       DATA (AM( 2,K, 2),K=0, 2)
41904      & / -0.1651006E+02,  0.7959721E+01,  0.8810563E+01 /
41905       DATA (AM( 3,K, 2),K=0, 2)
41906      & / -0.1643394E+02,  0.5892854E+01,  0.9348874E+01 /
41907       DATA (AM( 4,K, 2),K=0, 2)
41908      & /  0.3067422E+02,  0.4235796E+01, -0.5112136E+00 /
41909       DATA (AM( 5,K, 2),K=0, 2)
41910      & /  0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41911       DATA (AM( 6,K, 2),K=0, 2)
41912      & / -0.1095451E+02,  0.3006577E+01,  0.5638136E+01 /
41913       DATA (AM( 7,K, 2),K=0, 2)
41914      & / -0.1172251E+02, -0.2183624E+01,  0.4955794E+01 /
41915       DATA (AM( 8,K, 2),K=0, 2)
41916      & /  0.1662533E-01,  0.7622870E-02, -0.4895887E-03 /
41917  
41918       DATA MEXVEC( 1) / 8 /
41919       DATA MLFVEC( 1) / 2 /
41920       DATA UT1VEC( 1) /  0.2612618E+01 /
41921       DATA UT2VEC( 1) / -0.1258304E+06 /
41922       DATA ALFVEC( 1) /  0.3407552E+00 /
41923       DATA QMAVEC( 1) /  0.0000000E+00 /
41924       DATA (AM( 0,K, 1),K=0, 2)
41925      & /  0.9905300E+00, -0.4502235E+00,  0.1624441E+00 /
41926       DATA (AM( 1,K, 1),K=0, 2)
41927      & /  0.8867534E+00,  0.1630829E-01, -0.4049085E-01 /
41928       DATA (AM( 2,K, 1),K=0, 2)
41929      & /  0.8547974E+00,  0.3336301E+00,  0.1371388E+00 /
41930       DATA (AM( 3,K, 1),K=0, 2)
41931      & /  0.2941113E+00, -0.1527905E+01,  0.2331879E+00 /
41932       DATA (AM( 4,K, 1),K=0, 2)
41933      & /  0.3384235E+02,  0.3715315E+01,  0.8276930E+00 /
41934       DATA (AM( 5,K, 1),K=0, 2)
41935      & /  0.6230115E+01,  0.3134639E+01, -0.1729099E+01 /
41936       DATA (AM( 6,K, 1),K=0, 2)
41937      & / -0.1186928E+01, -0.3282460E+00,  0.1052020E+00 /
41938       DATA (AM( 7,K, 1),K=0, 2)
41939      & / -0.8545702E+01, -0.6247947E+01,  0.3692561E+01 /
41940       DATA (AM( 8,K, 1),K=0, 2)
41941      & /  0.1724598E-01,  0.7120465E-02,  0.4003646E-04 /
41942  
41943       DATA MEXVEC( 0) / 8 /
41944       DATA MLFVEC( 0) / 2 /
41945       DATA UT1VEC( 0) / -0.4656819E+00 /
41946       DATA UT2VEC( 0) / -0.2742390E+03 /
41947       DATA ALFVEC( 0) /  0.4491863E+00 /
41948       DATA QMAVEC( 0) /  0.0000000E+00 /
41949       DATA (AM( 0,K, 0),K=0, 2)
41950      & /  0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41951       DATA (AM( 1,K, 0),K=0, 2)
41952      & / -0.9421449E+02,  0.3995885E+01,  0.1607363E+01 /
41953       DATA (AM( 2,K, 0),K=0, 2)
41954      & /  0.4206383E+01,  0.2485954E+00,  0.2497468E+00 /
41955       DATA (AM( 3,K, 0),K=0, 2)
41956      & /  0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41957       DATA (AM( 4,K, 0),K=0, 2)
41958      & / -0.1013897E+03, -0.7113478E+00,  0.2621865E+00 /
41959       DATA (AM( 5,K, 0),K=0, 2)
41960      & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41961       DATA (AM( 6,K, 0),K=0, 2)
41962      & /  0.1627137E+01,  0.4954111E+00, -0.6387009E+00 /
41963       DATA (AM( 7,K, 0),K=0, 2)
41964      & /  0.1537698E+00, -0.2487878E+00,  0.8305947E+00 /
41965       DATA (AM( 8,K, 0),K=0, 2)
41966      & /  0.2496448E-01,  0.2457823E-02,  0.8234276E-03 /
41967  
41968       DATA MEXVEC(-1) / 8 /
41969       DATA MLFVEC(-1) / 2 /
41970       DATA UT1VEC(-1) /  0.3862583E+01 /
41971       DATA UT2VEC(-1) / -0.1265969E+01 /
41972       DATA ALFVEC(-1) /  0.2457668E+00 /
41973       DATA QMAVEC(-1) /  0.0000000E+00 /
41974       DATA (AM( 0,K,-1),K=0, 2)
41975      & /  0.2647441E+02,  0.1059277E+02, -0.9176654E+00 /
41976       DATA (AM( 1,K,-1),K=0, 2)
41977      & /  0.1990636E+01,  0.8558918E-01,  0.4248667E-01 /
41978       DATA (AM( 2,K,-1),K=0, 2)
41979      & / -0.1476095E+02, -0.3276255E+02,  0.1558110E+01 /
41980       DATA (AM( 3,K,-1),K=0, 2)
41981      & / -0.2966889E+01, -0.3649037E+02,  0.1195914E+01 /
41982       DATA (AM( 4,K,-1),K=0, 2)
41983      & / -0.1000519E+03, -0.2464635E+01,  0.1964849E+00 /
41984       DATA (AM( 5,K,-1),K=0, 2)
41985      & /  0.3718331E+02,  0.4700389E+02, -0.2772142E+01 /
41986       DATA (AM( 6,K,-1),K=0, 2)
41987      & / -0.1872722E+02, -0.2291189E+02,  0.1089052E+01 /
41988       DATA (AM( 7,K,-1),K=0, 2)
41989      & / -0.1628146E+02, -0.1823993E+02,  0.2537369E+01 /
41990       DATA (AM( 8,K,-1),K=0, 2)
41991      & / -0.1156300E+01, -0.1280495E+00,  0.5153245E-01 /
41992  
41993       DATA MEXVEC(-2) / 7 /
41994       DATA MLFVEC(-2) / 2 /
41995       DATA UT1VEC(-2) /  0.1895615E+00 /
41996       DATA UT2VEC(-2) / -0.3069097E+01 /
41997       DATA ALFVEC(-2) /  0.5293999E+00 /
41998       DATA QMAVEC(-2) /  0.0000000E+00 /
41999       DATA (AM( 0,K,-2),K=0, 2)
42000      & / -0.6556775E+00,  0.2490190E+00,  0.3966485E-01 /
42001       DATA (AM( 1,K,-2),K=0, 2)
42002      & /  0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
42003       DATA (AM( 2,K,-2),K=0, 2)
42004      & / -0.2371436E+01,  0.3566814E+00, -0.2834683E+00 /
42005       DATA (AM( 3,K,-2),K=0, 2)
42006      & / -0.6152826E+01,  0.8339877E+00, -0.7233230E+00 /
42007       DATA (AM( 4,K,-2),K=0, 2)
42008      & / -0.8346558E+01,  0.2892168E+01,  0.2137099E+00 /
42009       DATA (AM( 5,K,-2),K=0, 2)
42010      & /  0.1279530E+02,  0.1021114E+00,  0.5787439E+00 /
42011       DATA (AM( 6,K,-2),K=0, 2)
42012      & /  0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
42013       DATA (AM( 7,K,-2),K=0, 2)
42014      & / -0.2795725E+02, -0.5263392E+00,  0.1290229E+01 /
42015  
42016       DATA MEXVEC(-3) / 7 /
42017       DATA MLFVEC(-3) / 2 /
42018       DATA UT1VEC(-3) /  0.3753257E+01 /
42019       DATA UT2VEC(-3) / -0.1113085E+01 /
42020       DATA ALFVEC(-3) /  0.3713141E+00 /
42021       DATA QMAVEC(-3) /  0.0000000E+00 /
42022       DATA (AM( 0,K,-3),K=0, 2)
42023      & /  0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
42024       DATA (AM( 1,K,-3),K=0, 2)
42025      & /  0.2702644E+01,  0.6763243E+00,  0.7231586E-02 /
42026       DATA (AM( 2,K,-3),K=0, 2)
42027      & / -0.1857924E+02,  0.3907500E+01,  0.5850109E+01 /
42028       DATA (AM( 3,K,-3),K=0, 2)
42029      & / -0.3044793E+02,  0.2639332E+01,  0.5566644E+01 /
42030       DATA (AM( 4,K,-3),K=0, 2)
42031      & / -0.4258011E+01, -0.5429244E+01,  0.4418946E+00 /
42032       DATA (AM( 5,K,-3),K=0, 2)
42033      & /  0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
42034       DATA (AM( 6,K,-3),K=0, 2)
42035      & / -0.1658858E+02,  0.2923275E+01,  0.2266286E+01 /
42036       DATA (AM( 7,K,-3),K=0, 2)
42037      & / -0.1149263E+02,  0.2877475E+01, -0.7999105E+00 /
42038  
42039       DATA MEXVEC(-4) / 7 /
42040       DATA MLFVEC(-4) / 2 /
42041       DATA UT1VEC(-4) /  0.4400772E+01 /
42042       DATA UT2VEC(-4) / -0.1356116E+01 /
42043       DATA ALFVEC(-4) /  0.3712017E-01 /
42044       DATA QMAVEC(-4) /  0.1300000E+01 /
42045       DATA (AM( 0,K,-4),K=0, 2)
42046      & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
42047       DATA (AM( 1,K,-4),K=0, 2)
42048      & /  0.2754618E+01,  0.8338636E+00, -0.6885160E-01 /
42049       DATA (AM( 2,K,-4),K=0, 2)
42050      & / -0.1657987E+02,  0.1439143E+02, -0.6887240E+00 /
42051       DATA (AM( 3,K,-4),K=0, 2)
42052      & / -0.2800703E+02,  0.1535966E+02, -0.7377693E+00 /
42053       DATA (AM( 4,K,-4),K=0, 2)
42054      & / -0.6460216E+01, -0.4783019E+01,  0.4913297E+00 /
42055       DATA (AM( 5,K,-4),K=0, 2)
42056      & /  0.3141830E+02, -0.3178031E+02,  0.7136013E+01 /
42057       DATA (AM( 6,K,-4),K=0, 2)
42058      & / -0.1802509E+02,  0.1862163E+02, -0.4632843E+01 /
42059       DATA (AM( 7,K,-4),K=0, 2)
42060      & / -0.1240412E+02,  0.2565386E+02, -0.1066570E+02 /
42061  
42062       DATA MEXVEC(-5) / 6 /
42063       DATA MLFVEC(-5) / 2 /
42064       DATA UT1VEC(-5) /  0.5562568E+01 /
42065       DATA UT2VEC(-5) / -0.1801317E+01 /
42066       DATA ALFVEC(-5) /  0.4952010E-02 /
42067       DATA QMAVEC(-5) /  0.4500000E+01 /
42068       DATA (AM( 0,K,-5),K=0, 2)
42069      & / -0.6031237E+01,  0.1992727E+01, -0.1076331E+01 /
42070       DATA (AM( 1,K,-5),K=0, 2)
42071      & /  0.2933912E+01,  0.5839674E+00,  0.7509435E-01 /
42072       DATA (AM( 2,K,-5),K=0, 2)
42073      & / -0.8284919E+01,  0.1488593E+01, -0.8251678E+00 /
42074       DATA (AM( 3,K,-5),K=0, 2)
42075      & / -0.1925986E+02,  0.2805753E+01, -0.3015446E+01 /
42076       DATA (AM( 4,K,-5),K=0, 2)
42077      & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
42078       DATA (AM( 5,K,-5),K=0, 2)
42079      & /  0.2193195E+02, -0.1788518E+02,  0.9460908E+01 /
42080       DATA (AM( 6,K,-5),K=0, 2)
42081      & / -0.1327377E+02,  0.1201754E+02, -0.6277844E+01 /
42082  
42083       IF(Q .LE. QMAVEC(IFL)) THEN
42084          PYCT5L = 0.D0
42085          RETURN
42086       ENDIF
42087  
42088       IF(X .GE. 1.D0) THEN
42089          PYCT5L = 0.D0
42090          RETURN
42091       ENDIF
42092  
42093       TMP = LOG(Q/ALFVEC(IFL))
42094       IF(TMP .LE. 0.D0) THEN
42095          PYCT5L = 0.D0
42096          RETURN
42097       ENDIF
42098  
42099       SB = LOG(TMP)
42100       SB1 = SB - 1.2D0
42101       SB2 = SB1*SB1
42102  
42103       DO 110 I = 0, NEX
42104          AF(I) = 0.D0
42105          SBX = 1.D0
42106          DO 100 K = 0, MLFVEC(IFL)
42107             AF(I) = AF(I) + SBX*AM(I,K,IFL)
42108             SBX = SB1*SBX
42109   100    CONTINUE
42110   110 CONTINUE
42111  
42112       Y = -LOG(X)
42113       U = LOG(X/0.00001D0)
42114  
42115       PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42116       PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42117       PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42118       PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42119      &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42120  
42121       PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42122  
42123 C...Include threshold factor.
42124       PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
42125  
42126       RETURN
42127       END
42128  
42129 C*********************************************************************
42130  
42131 C...PYCT5M
42132 C...Auxiliary function for parametrization of CTEQ5M1.
42133 C...Author: J. Pumplin 9/99.
42134  
42135       FUNCTION PYCT5M(IFL,X,Q)
42136  
42137 C...Double precision declaration.
42138       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42139       IMPLICIT INTEGER(I-N)
42140  
42141       PARAMETER (NEX=8, NLF=2)
42142       DIMENSION AM(0:NEX,0:NLF,-5:2)
42143       DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
42144       DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
42145       DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
42146       DIMENSION AF(0:NEX)
42147  
42148       DATA MEXVEC( 2) / 8 /
42149       DATA MLFVEC( 2) / 2 /
42150       DATA UT1VEC( 2) /  0.5141718E+01 /
42151       DATA UT2VEC( 2) / -0.1346944E+01 /
42152       DATA ALFVEC( 2) /  0.5260555E+00 /
42153       DATA QMAVEC( 2) /  0.0000000E+00 /
42154       DATA (AM( 0,K, 2),K=0, 2)
42155      & /  0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
42156       DATA (AM( 1,K, 2),K=0, 2)
42157      & /  0.9839410E+00,  0.4168426E-01, -0.5018952E-01 /
42158       DATA (AM( 2,K, 2),K=0, 2)
42159      & / -0.1651961E+02,  0.9246261E+01,  0.5996400E+01 /
42160       DATA (AM( 3,K, 2),K=0, 2)
42161      & / -0.2077936E+02,  0.9786469E+01,  0.7656465E+01 /
42162       DATA (AM( 4,K, 2),K=0, 2)
42163      & /  0.3054926E+02,  0.1889536E+01,  0.1380541E+01 /
42164       DATA (AM( 5,K, 2),K=0, 2)
42165      & /  0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
42166       DATA (AM( 6,K, 2),K=0, 2)
42167      & / -0.1426778E+02,  0.6239537E+01,  0.5254819E+01 /
42168       DATA (AM( 7,K, 2),K=0, 2)
42169      & / -0.1909811E+02,  0.3695678E+01,  0.5495729E+01 /
42170       DATA (AM( 8,K, 2),K=0, 2)
42171      & /  0.1889751E-01,  0.5027193E-02,  0.6624896E-03 /
42172  
42173       DATA MEXVEC( 1) / 8 /
42174       DATA MLFVEC( 1) / 2 /
42175       DATA UT1VEC( 1) /  0.4138426E+01 /
42176       DATA UT2VEC( 1) / -0.3221374E+01 /
42177       DATA ALFVEC( 1) /  0.4960962E+00 /
42178       DATA QMAVEC( 1) /  0.0000000E+00 /
42179       DATA (AM( 0,K, 1),K=0, 2)
42180      & /  0.1332497E+01, -0.3703718E+00,  0.1288638E+00 /
42181       DATA (AM( 1,K, 1),K=0, 2)
42182      & /  0.7544687E+00,  0.3255075E-01, -0.4706680E-01 /
42183       DATA (AM( 2,K, 1),K=0, 2)
42184      & / -0.7638814E+00,  0.5008313E+00, -0.9237374E-01 /
42185       DATA (AM( 3,K, 1),K=0, 2)
42186      & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
42187       DATA (AM( 4,K, 1),K=0, 2)
42188      & /  0.3991610E+02,  0.1979881E+01,  0.1775814E+01 /
42189       DATA (AM( 5,K, 1),K=0, 2)
42190      & /  0.6201080E+01,  0.2046288E+01,  0.3804571E+00 /
42191       DATA (AM( 6,K, 1),K=0, 2)
42192      & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
42193       DATA (AM( 7,K, 1),K=0, 2)
42194      & / -0.8631305E+01, -0.3981200E+01,  0.6970153E+00 /
42195       DATA (AM( 8,K, 1),K=0, 2)
42196      & /  0.2371230E-01,  0.5372683E-02,  0.1118701E-02 /
42197  
42198       DATA MEXVEC( 0) / 8 /
42199       DATA MLFVEC( 0) / 2 /
42200       DATA UT1VEC( 0) / -0.1026789E+01 /
42201       DATA UT2VEC( 0) / -0.9051707E+01 /
42202       DATA ALFVEC( 0) /  0.9462977E+00 /
42203       DATA QMAVEC( 0) /  0.0000000E+00 /
42204       DATA (AM( 0,K, 0),K=0, 2)
42205      & /  0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
42206       DATA (AM( 1,K, 0),K=0, 2)
42207      & / -0.9449972E+02,  0.1074771E+01,  0.2056055E+01 /
42208       DATA (AM( 2,K, 0),K=0, 2)
42209      & /  0.3701064E+01, -0.1167947E-02,  0.1933573E+00 /
42210       DATA (AM( 3,K, 0),K=0, 2)
42211      & /  0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
42212       DATA (AM( 4,K, 0),K=0, 2)
42213      & / -0.1014453E+03, -0.5707427E+00,  0.4511242E-01 /
42214       DATA (AM( 5,K, 0),K=0, 2)
42215      & /  0.6365168E+01,  0.1275354E+01, -0.4964081E+00 /
42216       DATA (AM( 6,K, 0),K=0, 2)
42217      & / -0.3370693E+01, -0.1122020E+01,  0.5947751E-01 /
42218       DATA (AM( 7,K, 0),K=0, 2)
42219      & / -0.5327270E+01, -0.9293556E+00,  0.6629940E+00 /
42220       DATA (AM( 8,K, 0),K=0, 2)
42221      & /  0.2437513E-01,  0.1600939E-02,  0.6855336E-03 /
42222  
42223       DATA MEXVEC(-1) / 8 /
42224       DATA MLFVEC(-1) / 2 /
42225       DATA UT1VEC(-1) /  0.5243571E+01 /
42226       DATA UT2VEC(-1) / -0.2870513E+01 /
42227       DATA ALFVEC(-1) /  0.6701448E+00 /
42228       DATA QMAVEC(-1) /  0.0000000E+00 /
42229       DATA (AM( 0,K,-1),K=0, 2)
42230      & /  0.2428863E+02,  0.1907035E+01, -0.4606457E+00 /
42231       DATA (AM( 1,K,-1),K=0, 2)
42232      & /  0.2006810E+01, -0.1265915E+00,  0.7153556E-02 /
42233       DATA (AM( 2,K,-1),K=0, 2)
42234      & / -0.1884546E+02, -0.2339471E+01,  0.5740679E+01 /
42235       DATA (AM( 3,K,-1),K=0, 2)
42236      & / -0.2527892E+02, -0.2044124E+01,  0.1280470E+02 /
42237       DATA (AM( 4,K,-1),K=0, 2)
42238      & / -0.1013824E+03, -0.1594199E+01,  0.2216401E+00 /
42239       DATA (AM( 5,K,-1),K=0, 2)
42240      & /  0.8070930E+02,  0.1792072E+01, -0.2164364E+02 /
42241       DATA (AM( 6,K,-1),K=0, 2)
42242      & / -0.4641050E+02,  0.1977338E+00,  0.1273014E+02 /
42243       DATA (AM( 7,K,-1),K=0, 2)
42244      & / -0.3910568E+02,  0.1719632E+01,  0.1086525E+02 /
42245       DATA (AM( 8,K,-1),K=0, 2)
42246      & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
42247  
42248       DATA MEXVEC(-2) / 7 /
42249       DATA MLFVEC(-2) / 2 /
42250       DATA UT1VEC(-2) /  0.4782210E+01 /
42251       DATA UT2VEC(-2) / -0.1976856E+02 /
42252       DATA ALFVEC(-2) /  0.7558374E+00 /
42253       DATA QMAVEC(-2) /  0.0000000E+00 /
42254       DATA (AM( 0,K,-2),K=0, 2)
42255      & / -0.6216935E+00,  0.2369963E+00, -0.7909949E-02 /
42256       DATA (AM( 1,K,-2),K=0, 2)
42257      & /  0.1245440E+01, -0.1031510E+00,  0.4916523E-02 /
42258       DATA (AM( 2,K,-2),K=0, 2)
42259      & / -0.7060824E+01, -0.3875283E-01,  0.1784981E+00 /
42260       DATA (AM( 3,K,-2),K=0, 2)
42261      & / -0.7430595E+01,  0.1964572E+00, -0.1284999E+00 /
42262       DATA (AM( 4,K,-2),K=0, 2)
42263      & / -0.6897810E+01,  0.2620543E+01,  0.8012553E-02 /
42264       DATA (AM( 5,K,-2),K=0, 2)
42265      & /  0.1507713E+02,  0.2340307E-01,  0.2482535E+01 /
42266       DATA (AM( 6,K,-2),K=0, 2)
42267      & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
42268       DATA (AM( 7,K,-2),K=0, 2)
42269      & / -0.2571932E+02,  0.2903941E+00, -0.2848206E+01 /
42270  
42271       DATA MEXVEC(-3) / 7 /
42272       DATA MLFVEC(-3) / 2 /
42273       DATA UT1VEC(-3) /  0.4518239E+01 /
42274       DATA UT2VEC(-3) / -0.2690590E+01 /
42275       DATA ALFVEC(-3) /  0.6124079E+00 /
42276       DATA QMAVEC(-3) /  0.0000000E+00 /
42277       DATA (AM( 0,K,-3),K=0, 2)
42278      & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
42279       DATA (AM( 1,K,-3),K=0, 2)
42280      & /  0.2927174E+01,  0.4822709E+00, -0.1088787E-01 /
42281       DATA (AM( 2,K,-3),K=0, 2)
42282      & / -0.1771017E+02, -0.1416635E+01,  0.8467622E+01 /
42283       DATA (AM( 3,K,-3),K=0, 2)
42284      & / -0.4972782E+02, -0.3348547E+01,  0.1767061E+02 /
42285       DATA (AM( 4,K,-3),K=0, 2)
42286      & / -0.7102770E+01, -0.3205337E+01,  0.4101704E+00 /
42287       DATA (AM( 5,K,-3),K=0, 2)
42288      & /  0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
42289       DATA (AM( 6,K,-3),K=0, 2)
42290      & / -0.4090347E+02,  0.2103486E+01,  0.1416507E+02 /
42291       DATA (AM( 7,K,-3),K=0, 2)
42292      & / -0.2952639E+02,  0.5376136E+01,  0.7825585E+01 /
42293  
42294       DATA MEXVEC(-4) / 7 /
42295       DATA MLFVEC(-4) / 2 /
42296       DATA UT1VEC(-4) /  0.2783230E+01 /
42297       DATA UT2VEC(-4) / -0.1746328E+01 /
42298       DATA ALFVEC(-4) /  0.1115653E+01 /
42299       DATA QMAVEC(-4) /  0.1300000E+01 /
42300       DATA (AM( 0,K,-4),K=0, 2)
42301      & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
42302       DATA (AM( 1,K,-4),K=0, 2)
42303      & /  0.3345755E+01,  0.3187765E+00,  0.1378124E+00 /
42304       DATA (AM( 2,K,-4),K=0, 2)
42305      & / -0.2037615E+02,  0.4121687E+01,  0.2236520E+00 /
42306       DATA (AM( 3,K,-4),K=0, 2)
42307      & / -0.4703104E+02,  0.5353087E+01, -0.1455347E+01 /
42308       DATA (AM( 4,K,-4),K=0, 2)
42309      & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
42310       DATA (AM( 5,K,-4),K=0, 2)
42311      & /  0.5088892E+02, -0.8197304E+01,  0.8083451E+01 /
42312       DATA (AM( 6,K,-4),K=0, 2)
42313      & / -0.2819070E+02,  0.4554086E+01, -0.5890995E+01 /
42314       DATA (AM( 7,K,-4),K=0, 2)
42315      & / -0.1098238E+02,  0.2590096E+01, -0.8062879E+01 /
42316  
42317       DATA MEXVEC(-5) / 6 /
42318       DATA MLFVEC(-5) / 2 /
42319       DATA UT1VEC(-5) /  0.1619654E+02 /
42320       DATA UT2VEC(-5) / -0.3367346E+01 /
42321       DATA ALFVEC(-5) /  0.5109891E-02 /
42322       DATA QMAVEC(-5) /  0.4500000E+01 /
42323       DATA (AM( 0,K,-5),K=0, 2)
42324      & / -0.6800138E+01,  0.2493627E+01, -0.1075724E+01 /
42325       DATA (AM( 1,K,-5),K=0, 2)
42326      & /  0.3036555E+01,  0.3324733E+00,  0.2008298E+00 /
42327       DATA (AM( 2,K,-5),K=0, 2)
42328      & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
42329       DATA (AM( 3,K,-5),K=0, 2)
42330      & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
42331       DATA (AM( 4,K,-5),K=0, 2)
42332      & / -0.1099444E+02,  0.1320930E+01, -0.2353831E+01 /
42333       DATA (AM( 5,K,-5),K=0, 2)
42334      & /  0.1699299E+02, -0.3565802E+02,  0.3566872E+02 /
42335       DATA (AM( 6,K,-5),K=0, 2)
42336      & / -0.1465793E+02,  0.2703365E+02, -0.2176372E+02 /
42337  
42338       IF(Q .LE. QMAVEC(IFL)) THEN
42339          PYCT5M = 0.D0
42340          RETURN
42341       ENDIF
42342  
42343       IF(X .GE. 1.D0) THEN
42344          PYCT5M = 0.D0
42345          RETURN
42346       ENDIF
42347  
42348       TMP = LOG(Q/ALFVEC(IFL))
42349       IF(TMP .LE. 0.D0) THEN
42350          PYCT5M = 0.D0
42351          RETURN
42352       ENDIF
42353  
42354       SB = LOG(TMP)
42355       SB1 = SB - 1.2D0
42356       SB2 = SB1*SB1
42357  
42358       DO 110 I = 0, NEX
42359          AF(I) = 0.D0
42360          SBX = 1.D0
42361          DO 100 K = 0, MLFVEC(IFL)
42362             AF(I) = AF(I) + SBX*AM(I,K,IFL)
42363             SBX = SB1*SBX
42364   100    CONTINUE
42365   110 CONTINUE
42366  
42367       Y = -LOG(X)
42368       U = LOG(X/0.00001D0)
42369  
42370       PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42371       PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42372       PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42373       PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42374      &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42375  
42376       PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42377  
42378 C...Include threshold factor.
42379       PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
42380  
42381       RETURN
42382       END
42383  
42384 C*********************************************************************
42385  
42386 C...PYPDPO
42387 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
42388 C...a few older parametrizations, now obsolete but convenient for
42389 C...backwards checks.
42390  
42391       SUBROUTINE PYPDPO(X,Q2,XPPR)
42392  
42393 C...Double precision and integer declarations.
42394       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42395       IMPLICIT INTEGER(I-N)
42396       INTEGER PYK,PYCHGE,PYCOMP
42397 C...Commonblocks.
42398       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42399       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42400       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42401       COMMON/PYINT1/MINT(400),VINT(400)
42402       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
42403       DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
42404      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
42405  
42406  
42407 C...The following data lines are coefficients needed in the
42408 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
42409 C...parametrizations, see below.
42410 C...Powers of 1-x in different cases.
42411       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
42412 C...Expansion coefficients for up valence quark distribution.
42413       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
42414      1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
42415      2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
42416      3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
42417      4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
42418      5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
42419      6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
42420      1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
42421      2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
42422      3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
42423      4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
42424      5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
42425      6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
42426       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
42427      1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
42428      2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
42429      3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
42430      4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
42431      5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
42432      6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
42433      1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
42434      2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
42435      3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
42436      4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
42437      5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
42438      6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
42439 C...Expansion coefficients for down valence quark distribution.
42440       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
42441      1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
42442      2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
42443      3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
42444      4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
42445      5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
42446      6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
42447      1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
42448      2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
42449      3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
42450      4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
42451      5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
42452      6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
42453       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
42454      1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
42455      2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
42456      3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
42457      4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
42458      5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
42459      6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
42460      1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
42461      2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
42462      3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
42463      4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
42464      5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
42465      6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
42466 C...Expansion coefficients for up and down sea quark distributions.
42467       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
42468      1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
42469      2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
42470      3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
42471      4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
42472      5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
42473      6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
42474      1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
42475      2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
42476      3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
42477      4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
42478      5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
42479      6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
42480       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
42481      1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
42482      2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
42483      3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
42484      4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
42485      5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
42486      6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
42487      1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
42488      2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
42489      3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
42490      4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
42491      5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
42492      6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
42493 C...Expansion coefficients for gluon distribution.
42494       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
42495      1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
42496      2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
42497      3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
42498      4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
42499      5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
42500      6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
42501      1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
42502      2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
42503      3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
42504      4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
42505      5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
42506      6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
42507       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
42508      1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
42509      2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
42510      3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
42511      4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
42512      5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
42513      6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
42514      1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
42515      2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
42516      3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
42517      4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
42518      5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
42519      6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
42520 C...Expansion coefficients for strange sea quark distribution.
42521       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
42522      1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
42523      2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
42524      3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
42525      4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
42526      5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
42527      6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
42528      1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
42529      2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
42530      3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
42531      4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
42532      5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
42533      6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
42534       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
42535      1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
42536      2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
42537      3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
42538      4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
42539      5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
42540      6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
42541      1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
42542      2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
42543      3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
42544      4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
42545      5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
42546      6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
42547 C...Expansion coefficients for charm sea quark distribution.
42548       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
42549      1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
42550      2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
42551      3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
42552      4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
42553      5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
42554      6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
42555      1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
42556      2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
42557      3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
42558      4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
42559      5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
42560      6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
42561       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
42562      1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
42563      2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
42564      3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
42565      4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
42566      5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
42567      6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
42568      1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
42569      2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
42570      3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
42571      4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
42572      5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
42573      6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
42574 C...Expansion coefficients for bottom sea quark distribution.
42575       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
42576      1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
42577      2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
42578      3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
42579      4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
42580      5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
42581      6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
42582      1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
42583      2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
42584      3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
42585      4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
42586      5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
42587      6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
42588       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
42589      1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
42590      2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
42591      3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
42592      4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
42593      5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
42594      6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
42595      1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
42596      2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
42597      3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
42598      4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
42599      5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
42600      6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
42601 C...Expansion coefficients for top sea quark distribution.
42602       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
42603      1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
42604      2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
42605      3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
42606      4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42607      5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
42608      6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42609      1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
42610      2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
42611      3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
42612      4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
42613      5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
42614      6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
42615       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
42616      1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
42617      2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
42618      3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
42619      4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42620      5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
42621      6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42622      1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
42623      2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
42624      3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
42625      4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
42626      5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
42627      6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
42628  
42629 C...The following data lines are coefficients needed in the
42630 C...Duke, Owens proton structure function parametrizations, see below.
42631 C...Expansion coefficients for (up+down) valence quark distribution.
42632       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
42633      1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42634      2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42635      3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42636       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
42637      1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42638      2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42639      3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42640 C...Expansion coefficients for down valence quark distribution.
42641       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
42642      1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42643      2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42644      3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42645       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
42646      1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42647      2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42648      3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42649 C...Expansion coefficients for (up+down+strange) sea quark distribution.
42650       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
42651      1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42652      2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
42653      3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
42654       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
42655      1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42656      2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
42657      3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
42658 C...Expansion coefficients for charm sea quark distribution.
42659       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
42660      1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42661      2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
42662      3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
42663        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
42664      1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42665      2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
42666      3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
42667 C...Expansion coefficients for gluon distribution.
42668       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
42669      1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42670      2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
42671      3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
42672       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
42673      1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42674      2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
42675      3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
42676  
42677 C...Euler's beta function, requires ordinary Gamma function
42678       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
42679  
42680 C...Leading order proton parton distributions from Glueck, Reya and
42681 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
42682 C...10^-5 < x < 1.
42683       IF(MSTP(51).EQ.11) THEN
42684  
42685 C...Determine s expansion variable and some x expressions.
42686         Q2IN=MIN(1D8,MAX(0.25D0,Q2))
42687         SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
42688         SD2=SD**2
42689         XL=-LOG(X)
42690         XS=SQRT(X)
42691  
42692 C...Evaluate valence, gluon and sea distributions.
42693         XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
42694      &  X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
42695      &  (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
42696      &  (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
42697         XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
42698      &  (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
42699      &  1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
42700         XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
42701      &  (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
42702      &  1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
42703      &  SQRT(4.066D0*SD**1.218D0*XL)))*
42704      &  (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
42705         XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
42706      &  1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
42707      &  SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
42708      &  XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
42709         XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
42710      &  (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
42711      &  EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
42712      &  SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
42713         IF(SD.LE.0.888D0) THEN
42714           XFCHM=0D0
42715         ELSE
42716           XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
42717      &    (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
42718      &    SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
42719         ENDIF
42720         IF(SD.LE.1.351D0) THEN
42721           XFBOT=0D0
42722         ELSE
42723           XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
42724      &    1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
42725      &    SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
42726         ENDIF
42727  
42728 C...Put into output array.
42729         XPPR(0)=XFGLU
42730         XPPR(1)=XFVDD+XFSEA
42731         XPPR(2)=XFVUD-XFVDD+XFSEA
42732         XPPR(3)=XFSTR
42733         XPPR(4)=XFCHM
42734         XPPR(5)=XFBOT
42735         XPPR(-1)=XFSEA
42736         XPPR(-2)=XFSEA
42737         XPPR(-3)=XFSTR
42738         XPPR(-4)=XFCHM
42739         XPPR(-5)=XFBOT
42740  
42741 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42742 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42743       ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42744  
42745 C...Determine set, Lambda and x and t expansion variables.
42746         NSET=MSTP(51)-11
42747         IF(NSET.EQ.1) ALAM=0.2D0
42748         IF(NSET.EQ.2) ALAM=0.29D0
42749         TMIN=LOG(5D0/ALAM**2)
42750         TMAX=LOG(1D8/ALAM**2)
42751         T=LOG(MAX(1D0,Q2/ALAM**2))
42752         VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42753         NX=1
42754         IF(X.LE.0.1D0) NX=2
42755         IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42756         IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42757  
42758 C...Chebyshev polynomials for x and t expansion.
42759         TX(1)=1D0
42760         TX(2)=VX
42761         TX(3)=2D0*VX**2-1D0
42762         TX(4)=4D0*VX**3-3D0*VX
42763         TX(5)=8D0*VX**4-8D0*VX**2+1D0
42764         TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42765         TT(1)=1D0
42766         TT(2)=VT
42767         TT(3)=2D0*VT**2-1D0
42768         TT(4)=4D0*VT**3-3D0*VT
42769         TT(5)=8D0*VT**4-8D0*VT**2+1D0
42770         TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42771  
42772 C...Calculate structure functions.
42773         DO 120 KFL=1,6
42774           XQSUM=0D0
42775           DO 110 IT=1,6
42776             DO 100 IX=1,6
42777               XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42778   100       CONTINUE
42779   110     CONTINUE
42780           XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42781   120   CONTINUE
42782  
42783 C...Put into output array.
42784         XPPR(0)=XQ(4)
42785         XPPR(1)=XQ(2)+XQ(3)
42786         XPPR(2)=XQ(1)+XQ(3)
42787         XPPR(3)=XQ(5)
42788         XPPR(4)=XQ(6)
42789         XPPR(-1)=XQ(3)
42790         XPPR(-2)=XQ(3)
42791         XPPR(-3)=XQ(5)
42792         XPPR(-4)=XQ(6)
42793  
42794 C...Special expansion for bottom (threshold effects).
42795         IF(MSTP(58).GE.5) THEN
42796           IF(NSET.EQ.1) TMIN=8.1905D0
42797           IF(NSET.EQ.2) TMIN=7.4474D0
42798           IF(T.GT.TMIN) THEN
42799             VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42800             TT(1)=1D0
42801             TT(2)=VT
42802             TT(3)=2D0*VT**2-1D0
42803             TT(4)=4D0*VT**3-3D0*VT
42804             TT(5)=8D0*VT**4-8D0*VT**2+1D0
42805             TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42806             XQSUM=0D0
42807             DO 140 IT=1,6
42808               DO 130 IX=1,6
42809                 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42810   130         CONTINUE
42811   140       CONTINUE
42812             XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42813             XPPR(-5)=XPPR(5)
42814           ENDIF
42815         ENDIF
42816  
42817 C...Special expansion for top (threshold effects).
42818         IF(MSTP(58).GE.6) THEN
42819           IF(NSET.EQ.1) TMIN=11.5528D0
42820           IF(NSET.EQ.2) TMIN=10.8097D0
42821           TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42822           TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42823           IF(T.GT.TMIN) THEN
42824             VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42825             TT(1)=1D0
42826             TT(2)=VT
42827             TT(3)=2D0*VT**2-1D0
42828             TT(4)=4D0*VT**3-3D0*VT
42829             TT(5)=8D0*VT**4-8D0*VT**2+1D0
42830             TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42831             XQSUM=0D0
42832             DO 160 IT=1,6
42833               DO 150 IX=1,6
42834                 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42835   150         CONTINUE
42836   160       CONTINUE
42837             XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42838             XPPR(-6)=XPPR(6)
42839           ENDIF
42840         ENDIF
42841  
42842 C...Proton parton distributions from Duke, Owens.
42843 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42844       ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42845  
42846 C...Determine set, Lambda and s expansion parameter.
42847         NSET=MSTP(51)-13
42848         IF(NSET.EQ.1) ALAM=0.2D0
42849         IF(NSET.EQ.2) ALAM=0.4D0
42850         Q2IN=MIN(1D6,MAX(4D0,Q2))
42851         SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42852  
42853 C...Calculate structure functions.
42854         DO 180 KFL=1,5
42855           DO 170 IS=1,6
42856             TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42857      &      CDO(3,IS,KFL,NSET)*SD**2
42858   170     CONTINUE
42859           IF(KFL.LE.2) THEN
42860             XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42861      &      TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42862           ELSE
42863             XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42864      &      TS(5)*X**2+TS(6)*X**3)
42865           ENDIF
42866   180   CONTINUE
42867  
42868 C...Put into output arrays.
42869         XPPR(0)=XQ(5)
42870         XPPR(1)=XQ(2)+XQ(3)/6D0
42871         XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42872         XPPR(3)=XQ(3)/6D0
42873         XPPR(4)=XQ(4)
42874         XPPR(-1)=XQ(3)/6D0
42875         XPPR(-2)=XQ(3)/6D0
42876         XPPR(-3)=XQ(3)/6D0
42877         XPPR(-4)=XQ(4)
42878  
42879       ENDIF
42880  
42881       RETURN
42882       END
42883  
42884 C*********************************************************************
42885  
42886 C...PYHFTH
42887 C...Gives threshold attractive/repulsive factor for heavy flavour
42888 C...production.
42889  
42890       FUNCTION PYHFTH(SH,SQM,FRATT)
42891  
42892 C...Double precision and integer declarations.
42893       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42894       IMPLICIT INTEGER(I-N)
42895       INTEGER PYK,PYCHGE,PYCOMP
42896 C...Commonblocks.
42897       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42898       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42899       COMMON/PYINT1/MINT(400),VINT(400)
42900       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42901  
42902 C...Value for alpha_strong.
42903       IF(MSTP(35).LE.1) THEN
42904         ALSSG=PARP(35)
42905       ELSE
42906         MST115=MSTU(115)
42907         MSTU(115)=MSTP(36)
42908         Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42909      &  PARP(36)**2)))
42910         ALSSG=PYALPS(Q2BN)
42911         MSTU(115)=MST115
42912       ENDIF
42913  
42914 C...Evaluate attractive and repulsive factors.
42915       XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42916       FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42917       XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42918       FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42919       PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42920       VINT(138)=PYHFTH
42921  
42922       RETURN
42923       END
42924  
42925 C*********************************************************************
42926  
42927 C...PYSPLI
42928 C...Splits a hadron remnant into two (partons or hadron + parton)
42929 C...in case it is more complicated than just a quark or a diquark.
42930  
42931       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42932  
42933 C...Double precision and integer declarations.
42934       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42935       IMPLICIT INTEGER(I-N)
42936       INTEGER PYK,PYCHGE,PYCOMP
42937 C...Commonblocks. PYDAT1 temporary
42938       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42939       COMMON/PYINT1/MINT(400),VINT(400)
42940       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42941       SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42942 C...Local array.
42943       DIMENSION KFL(3)
42944  
42945 C...Preliminaries. Parton composition.
42946       KFA=IABS(KF)
42947       KFS=ISIGN(1,KF)
42948       KFL(1)=MOD(KFA/1000,10)
42949       KFL(2)=MOD(KFA/100,10)
42950       KFL(3)=MOD(KFA/10,10)
42951       IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42952         KFL(2)=INT(1.5D0+PYR(0))
42953         IF(MINT(105).EQ.333) KFL(2)=3
42954         IF(MINT(105).EQ.443) KFL(2)=4
42955         KFL(3)=KFL(2)
42956       ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42957         KFL(2)=2
42958         KFL(3)=2
42959       ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42960         KFL(2)=1
42961         KFL(3)=1
42962       ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42963         KFL(2)=MOD(KFA/10,10)
42964         KFL(3)=MOD(KFA/100,10)
42965       ENDIF
42966       IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42967         KFLR=KFLIN*KFS
42968       ELSE
42969         KFLR=KFLIN
42970       ENDIF
42971       KFLCH=0
42972  
42973 C...Subdivide lepton.
42974       IF(KFA.GE.11.AND.KFA.LE.18) THEN
42975         IF(KFLR.EQ.KFA) THEN
42976           KFLSP=KFS*22
42977         ELSEIF(KFLR.EQ.22) THEN
42978           KFLSP=KFA
42979         ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42980           KFLSP=KFA+1
42981         ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42982           KFLSP=KFA-1
42983         ELSEIF(KFLR.EQ.21) THEN
42984           KFLSP=KFA
42985           KFLCH=KFS*21
42986         ELSE
42987           KFLSP=KFA
42988           KFLCH=-KFLR
42989         ENDIF
42990  
42991 C...Subdivide photon.
42992       ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42993         IF(KFLR.NE.21) THEN
42994           KFLSP=-KFLR
42995         ELSE
42996           RAGR=0.75D0*PYR(0)
42997           KFLSP=1
42998           IF(RAGR.GT.0.125D0) KFLSP=2
42999           IF(RAGR.GT.0.625D0) KFLSP=3
43000           IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
43001           KFLCH=-KFLSP
43002         ENDIF
43003  
43004 C...Subdivide Reggeon or Pomeron.
43005       ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
43006         IF(KFLIN.EQ.21) THEN
43007           KFLSP=KFS*21
43008         ELSE
43009           KFLSP=-KFLIN
43010         ENDIF
43011  
43012 C...Subdivide meson.
43013       ELSEIF(KFL(1).EQ.0) THEN
43014         KFL(2)=KFL(2)*(-1)**KFL(2)
43015         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
43016         IF(KFLR.EQ.KFL(2)) THEN
43017           KFLSP=KFL(3)
43018         ELSEIF(KFLR.EQ.KFL(3)) THEN
43019           KFLSP=KFL(2)
43020         ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
43021           KFLSP=KFL(2)
43022           KFLCH=KFL(3)
43023         ELSEIF(KFLR.EQ.21) THEN
43024           KFLSP=KFL(3)
43025           KFLCH=KFL(2)
43026         ELSEIF(KFLR*KFL(2).GT.0) THEN
43027           NTRY=0
43028   100     NTRY=NTRY+1
43029           CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
43030           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43031             GOTO 100
43032           ELSEIF(KFLCH.EQ.0) THEN
43033             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43034             MINT(51)=1
43035             RETURN
43036           ENDIF
43037           KFLSP=KFL(3)
43038         ELSE
43039           NTRY=0
43040   110     NTRY=NTRY+1
43041           CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
43042           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43043             GOTO 110
43044           ELSEIF(KFLCH.EQ.0) THEN
43045             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43046             MINT(51)=1
43047             RETURN
43048           ENDIF
43049           KFLSP=KFL(2)
43050         ENDIF
43051 
43052 C...Special case for extracting photon from baryon without splitting
43053 C...the latter. (Currently only used by external programs.)
43054       ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
43055         KFLSP=KFA
43056         KFLCH=0
43057  
43058 C...Subdivide baryon.
43059       ELSE
43060         NAGR=0
43061         DO 120 J=1,3
43062           IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
43063   120   CONTINUE
43064         IF(NAGR.GE.1) THEN
43065           RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
43066           IAGR=0
43067           DO 130 J=1,3
43068             IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
43069             IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
43070   130     CONTINUE
43071         ELSE
43072           IAGR=1.00001D0+2.99998D0*PYR(0)
43073         ENDIF
43074         ID1=1
43075         IF(IAGR.EQ.1) ID1=2
43076         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
43077         ID2=6-IAGR-ID1
43078         KSP=3
43079         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
43080           IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
43081         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
43082           IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
43083         ELSEIF(MOD(KFA,10).EQ.2) THEN
43084           IF(IAGR.EQ.1) KSP=1
43085           IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
43086         ENDIF
43087         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
43088         IF(KFLR.EQ.21) THEN
43089           KFLCH=KFL(IAGR)
43090         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
43091           NTRY=0
43092   140     NTRY=NTRY+1
43093           CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
43094           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43095             GOTO 140
43096           ELSEIF(KFLCH.EQ.0) THEN
43097             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43098             MINT(51)=1
43099             RETURN
43100           ENDIF
43101         ELSEIF(NAGR.EQ.0) THEN
43102           NTRY=0
43103   150     NTRY=NTRY+1
43104           CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
43105           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43106             GOTO 150
43107           ELSEIF(KFLCH.EQ.0) THEN
43108             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43109             MINT(51)=1
43110             RETURN
43111           ENDIF
43112           KFLSP=KFL(IAGR)
43113         ENDIF
43114       ENDIF
43115  
43116 C...Add on correct sign for result.
43117       KFLCH=KFLCH*KFS
43118       KFLSP=KFLSP*KFS
43119  
43120       RETURN
43121       END
43122  
43123 C*********************************************************************
43124  
43125 C...PYGAMM
43126 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
43127 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
43128 C...(Dover, 1965) 6.1.36.
43129  
43130       FUNCTION PYGAMM(X)
43131  
43132 C...Double precision and integer declarations.
43133       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43134       IMPLICIT INTEGER(I-N)
43135       INTEGER PYK,PYCHGE,PYCOMP
43136 C...Local array and data.
43137       DIMENSION B(8)
43138       DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
43139      &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
43140  
43141       NX=INT(X)
43142       DX=X-NX
43143  
43144       PYGAMM=1D0
43145       DXP=1D0
43146       DO 100 I=1,8
43147         DXP=DXP*DX
43148         PYGAMM=PYGAMM+B(I)*DXP
43149   100 CONTINUE
43150       IF(X.LT.1D0) THEN
43151         PYGAMM=PYGAMM/X
43152       ELSE
43153         DO 110 IX=1,NX-1
43154           PYGAMM=(X-IX)*PYGAMM
43155   110   CONTINUE
43156       ENDIF
43157  
43158       RETURN
43159       END
43160  
43161 C***********************************************************************
43162  
43163 C...PYWAUX
43164 C...Calculates real and imaginary parts of the auxiliary functions W1
43165 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
43166 C...der Bij, Nucl. Phys. B297 (1988) 221.
43167  
43168       SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
43169  
43170 C...Double precision and integer declarations.
43171       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43172       IMPLICIT INTEGER(I-N)
43173       INTEGER PYK,PYCHGE,PYCOMP
43174 C...Commonblocks.
43175       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43176       SAVE /PYDAT1/
43177  
43178       ASINH(X)=LOG(X+SQRT(X**2+1D0))
43179       ACOSH(X)=LOG(X+SQRT(X**2-1D0))
43180  
43181       IF(EPS.LT.0D0) THEN
43182         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
43183         IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
43184         WIM=0D0
43185       ELSEIF(EPS.LT.1D0) THEN
43186         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
43187         IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
43188         IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
43189         IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
43190       ELSE
43191         IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
43192         IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
43193         WIM=0D0
43194       ENDIF
43195  
43196       RETURN
43197       END
43198  
43199 C***********************************************************************
43200  
43201 C...PYI3AU
43202 C...Calculates real and imaginary parts of the auxiliary function I3;
43203 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
43204 C...Nucl. Phys. B297 (1988) 221.
43205  
43206       SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
43207  
43208 C...Double precision and integer declarations.
43209       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43210       IMPLICIT INTEGER(I-N)
43211       INTEGER PYK,PYCHGE,PYCOMP
43212 C...Commonblocks.
43213       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43214       SAVE /PYDAT1/
43215  
43216       BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
43217       IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
43218  
43219       IF(EPS.LT.0D0) THEN
43220         IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43221           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43222      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43223      &    PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
43224      &    PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
43225      &    LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
43226      &    LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
43227      &    LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
43228      &    EPS))
43229         ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43230           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43231      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43232      &    PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
43233      &    PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
43234      &    0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
43235      &    LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
43236      &    LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
43237         ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43238           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43239      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43240      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
43241      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
43242      &    0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
43243      &    LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
43244      &    LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
43245         ELSE
43246           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43247      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
43248      &    PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
43249      &    LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
43250      &    LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
43251         ENDIF
43252         F3IM=0D0
43253       ELSEIF(EPS.LT.1D0) THEN
43254         IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43255           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43256      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43257      &    PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
43258      &    PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
43259      &    (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43260      &    (0.25D0*(RAT+1D0)*EPS))
43261           F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43262      &    (0.25D0*(RAT+1D0)*EPS))
43263         ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43264           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43265      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43266      &    PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
43267      &    PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
43268      &    LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
43269      &    LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43270           F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43271         ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43272           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43273      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43274      &    PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
43275      &    PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
43276      &    LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
43277      &    (1D0+0.25D0*RAT*EPS-GA))
43278           F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
43279      &    (1D0+0.25D0*RAT*EPS-GA))
43280         ELSE
43281           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43282      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
43283      &    PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
43284      &    LOG((GA+BE-1D0)/(BE-GA))
43285           F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
43286         ENDIF
43287       ELSE
43288         RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
43289         RCTHE=RSQ*(1D0-2D0*BE/EPS)
43290         RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
43291         RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
43292         RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
43293         R=SQRT(RSQ)
43294         THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
43295         PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
43296         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
43297      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
43298      &  (PHI-THE)*(PHI+THE-PARU(1))
43299         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
43300      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
43301       ENDIF
43302  
43303       Y3RE=2D0/(2D0*BE-1D0)*F3RE
43304       Y3IM=2D0/(2D0*BE-1D0)*F3IM
43305  
43306       RETURN
43307       END
43308  
43309 C***********************************************************************
43310  
43311 C...PYSPEN
43312 C...Calculates real and imaginary part of Spence function; see
43313 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
43314  
43315       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
43316  
43317 C...Double precision and integer declarations.
43318       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43319       IMPLICIT INTEGER(I-N)
43320       INTEGER PYK,PYCHGE,PYCOMP
43321 C...Commonblocks.
43322       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43323       SAVE /PYDAT1/
43324 C...Local array and data.
43325       DIMENSION B(0:14)
43326       DATA B/
43327      &1.000000D+00,        -5.000000D-01,         1.666667D-01,
43328      &0.000000D+00,        -3.333333D-02,         0.000000D+00,
43329      &2.380952D-02,         0.000000D+00,        -3.333333D-02,
43330      &0.000000D+00,         7.575757D-02,         0.000000D+00,
43331      &-2.531135D-01,         0.000000D+00,         1.166667D+00/
43332  
43333       XRE=XREIN
43334       XIM=XIMIN
43335       IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
43336         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
43337         IF(IREIM.EQ.2) PYSPEN=0D0
43338         RETURN
43339       ENDIF
43340  
43341       XMOD=SQRT(XRE**2+XIM**2)
43342       IF(XMOD.LT.1D-6) THEN
43343         IF(IREIM.EQ.1) PYSPEN=0D0
43344         IF(IREIM.EQ.2) PYSPEN=0D0
43345         RETURN
43346       ENDIF
43347  
43348       XARG=SIGN(ACOS(XRE/XMOD),XIM)
43349       SP0RE=0D0
43350       SP0IM=0D0
43351       SGN=1D0
43352       IF(XMOD.GT.1D0) THEN
43353         ALGXRE=LOG(XMOD)
43354         ALGXIM=XARG-SIGN(PARU(1),XARG)
43355         SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
43356         SP0IM=-ALGXRE*ALGXIM
43357         SGN=-1D0
43358         XMOD=1D0/XMOD
43359         XARG=-XARG
43360         XRE=XMOD*COS(XARG)
43361         XIM=XMOD*SIN(XARG)
43362       ENDIF
43363       IF(XRE.GT.0.5D0) THEN
43364         ALGXRE=LOG(XMOD)
43365         ALGXIM=XARG
43366         XRE=1D0-XRE
43367         XIM=-XIM
43368         XMOD=SQRT(XRE**2+XIM**2)
43369         XARG=SIGN(ACOS(XRE/XMOD),XIM)
43370         ALGYRE=LOG(XMOD)
43371         ALGYIM=XARG
43372         SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
43373         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
43374         SGN=-SGN
43375       ENDIF
43376  
43377       XRE=1D0-XRE
43378       XIM=-XIM
43379       XMOD=SQRT(XRE**2+XIM**2)
43380       XARG=SIGN(ACOS(XRE/XMOD),XIM)
43381       ZRE=-LOG(XMOD)
43382       ZIM=-XARG
43383  
43384       SPRE=0D0
43385       SPIM=0D0
43386       SAVERE=1D0
43387       SAVEIM=0D0
43388       DO 100 I=0,14
43389         IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
43390         TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
43391         TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
43392         SAVERE=TERMRE
43393         SAVEIM=TERMIM
43394         SPRE=SPRE+B(I)*TERMRE
43395         SPIM=SPIM+B(I)*TERMIM
43396   100 CONTINUE
43397  
43398   110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
43399       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
43400  
43401       RETURN
43402       END
43403  
43404 C***********************************************************************
43405  
43406 C...PYQQBH
43407 C...Calculates the matrix element for the processes
43408 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
43409 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
43410 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
43411  
43412       SUBROUTINE PYQQBH(WTQQBH)
43413  
43414 C...Double precision and integer declarations.
43415       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43416       IMPLICIT INTEGER(I-N)
43417       INTEGER PYK,PYCHGE,PYCOMP
43418 C...Commonblocks.
43419       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43420       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43421       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43422       COMMON/PYINT1/MINT(400),VINT(400)
43423       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43424       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
43425 C...Local arrays and function.
43426       DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
43427       DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
43428      &PP(I,3)*PP(J,3)
43429  
43430 C...Mass parameters.
43431       WTQQBH=0D0
43432       ISUB=MINT(1)
43433       SHPR=SQRT(VINT(26))*VINT(1)
43434       PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
43435       PH=SQRT(VINT(21))*VINT(1)
43436       SPQ=PQ**2
43437       SPH=PH**2
43438  
43439 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
43440       DO 100 I=1,2
43441         PT=SQRT(MAX(0D0,VINT(197+5*I)))
43442         PP(I,1)=PT*COS(VINT(198+5*I))
43443         PP(I,2)=PT*SIN(VINT(198+5*I))
43444   100 CONTINUE
43445       PP(3,1)=-PP(1,1)-PP(2,1)
43446       PP(3,2)=-PP(1,2)-PP(2,2)
43447       PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
43448       PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
43449       PMS3=SPH+PP(3,1)**2+PP(3,2)**2
43450       PMT3=SQRT(PMS3)
43451       PP(3,3)=PMT3*SINH(VINT(211))
43452       PP(3,4)=PMT3*COSH(VINT(211))
43453       PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
43454       PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43455      &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
43456       PP(2,3)=-PP(1,3)-PP(3,3)
43457       PP(1,4)=SQRT(PMS1+PP(1,3)**2)
43458       PP(2,4)=SQRT(PMS2+PP(2,3)**2)
43459  
43460 C...Set up incoming kinematics and derived momentum combinations.
43461       DO 110 I=4,5
43462         PP(I,1)=0D0
43463         PP(I,2)=0D0
43464         PP(I,3)=-0.5D0*SHPR*(-1)**I
43465         PP(I,4)=-0.5D0*SHPR
43466   110 CONTINUE
43467       DO 120 J=1,4
43468         PP(6,J)=PP(1,J)+PP(2,J)
43469         PP(7,J)=PP(1,J)+PP(3,J)
43470         PP(8,J)=PP(1,J)+PP(4,J)
43471         PP(9,J)=PP(1,J)+PP(5,J)
43472         PP(10,J)=-PP(2,J)-PP(3,J)
43473         PP(11,J)=-PP(2,J)-PP(4,J)
43474         PP(12,J)=-PP(2,J)-PP(5,J)
43475         PP(13,J)=-PP(4,J)-PP(5,J)
43476   120 CONTINUE
43477  
43478 C...Derived kinematics invariants.
43479       X1=DOT(1,2)
43480       X2=DOT(1,3)
43481       X3=DOT(1,4)
43482       X4=DOT(1,5)
43483       X5=DOT(2,3)
43484       X6=DOT(2,4)
43485       X7=DOT(2,5)
43486       X8=DOT(3,4)
43487       X9=DOT(3,5)
43488       X10=DOT(4,5)
43489  
43490 C...Propagators.
43491       SS1=DOT(7,7)-SPQ
43492       SS2=DOT(8,8)-SPQ
43493       SS3=DOT(9,9)-SPQ
43494       SS4=DOT(10,10)-SPQ
43495       SS5=DOT(11,11)-SPQ
43496       SS6=DOT(12,12)-SPQ
43497       SS7=DOT(13,13)
43498       DX(1)=SS1*SS6
43499       DX(2)=SS2*SS6
43500       DX(3)=SS2*SS4
43501       DX(4)=SS1*SS5
43502       DX(5)=SS3*SS5
43503       DX(6)=SS3*SS4
43504       DX(7)=SS7*SS1
43505       DX(8)=SS7*SS4
43506  
43507 C...Define colour coefficients for g + g -> Q + Qbar + H.
43508       IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
43509         DO 140 I=1,3
43510           DO 130 J=1,3
43511             CLR(I,J)=16D0/3D0
43512             CLR(I+3,J+3)=16D0/3D0
43513             CLR(I,J+3)=-2D0/3D0
43514             CLR(I+3,J)=-2D0/3D0
43515   130     CONTINUE
43516   140   CONTINUE
43517         DO 160 L=1,2
43518           DO 150 I=1,3
43519             CLR(I,6+L)=-6D0
43520             CLR(I+3,6+L)=6D0
43521             CLR(6+L,I)=-6D0
43522             CLR(6+L,I+3)=6D0
43523   150     CONTINUE
43524   160   CONTINUE
43525         DO 180 K1=1,2
43526           DO 170 K2=1,2
43527             CLR(6+K1,6+K2)=12D0
43528   170     CONTINUE
43529   180   CONTINUE
43530  
43531 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
43532         FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
43533      &  X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
43534      &  X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
43535         FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
43536      &  *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
43537      &  X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
43538      &  X10)
43539         FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
43540      &  X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
43541      &  +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43542      &  -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
43543      &  -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
43544      &  X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
43545         FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
43546      &  X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
43547      &  )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
43548      &  4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
43549      &  X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
43550         FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
43551      &  X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43552      &  X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
43553      &  *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
43554      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
43555      &  X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
43556      &  +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
43557      &  X4*X6*X5)
43558         FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
43559      &  X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
43560      &  X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
43561      &  *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
43562      &  +X4*X9*X5+X4*X5**2)
43563         FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
43564      &  PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
43565      &  X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
43566      &  X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
43567      &  X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
43568      &  X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
43569         FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
43570      &  PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
43571      &  2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
43572      &  X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
43573      &  +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
43574      &  X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
43575      &  X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
43576      &  X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
43577      &  X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
43578         FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
43579      &  X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
43580         FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
43581      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
43582      &  X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
43583      &  X6)
43584         FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
43585      &  X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43586      &  X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
43587      &  *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
43588      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
43589      &  *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
43590      &  X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
43591      &  X5+X4*X6*X5)
43592         FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
43593      &  *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
43594      &  2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
43595      &  X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
43596      &  X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
43597      &  *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
43598      &  X6**2)
43599         FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
43600      &  X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
43601      &  X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
43602      &  X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
43603      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
43604      &  X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
43605      &  -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
43606      &  X4*X6*X5)
43607         FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43608      &  2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43609      &  X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
43610      &  X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
43611      &  *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
43612      &  +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43613      &  -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
43614      &  X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
43615      &  X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
43616      &  X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
43617      &  *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
43618         FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43619      &  2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43620      &  X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
43621      &  X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
43622      &  *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
43623      &  X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43624      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
43625      &  X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
43626      &  *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
43627      &  X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
43628      &  X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
43629         FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
43630      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
43631      &  X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
43632         FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
43633      &  X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
43634      &  X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
43635      &  *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
43636      &  +X3*X8*X5+X3*X5**2)
43637         FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
43638      &  X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
43639      &  X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
43640      &  *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
43641      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
43642      &  *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
43643      &  X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
43644      &  X5+X4*X6*X5)
43645         FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
43646      &  X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
43647      &  )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
43648      &  X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
43649      &  X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
43650         FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
43651      &  PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
43652      &  X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
43653      &  X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
43654      &  X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
43655      &  X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
43656      &  X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
43657      &  *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
43658      &  +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
43659         FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
43660      &  PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
43661      &  4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
43662      &  +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
43663      &  X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
43664      &  *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
43665         FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
43666      &  X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
43667      &  X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
43668         FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
43669      &  *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
43670      &  X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
43671      &  X10)
43672         FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
43673      &  X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
43674      &  +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43675      &  -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
43676      &  -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
43677      &  X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
43678         FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
43679      &  *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
43680      &  X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
43681      &  X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
43682      &  X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
43683      &  X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
43684         FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
43685      &  *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
43686      &  +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
43687      &  *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
43688      &  X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
43689      &  *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
43690      &  *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
43691      &  *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
43692      &  X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
43693         FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
43694      &  X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
43695         FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
43696      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
43697      &  X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
43698      &  X7)
43699         FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43700      &  4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43701      &  X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
43702      &  3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
43703      &  2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
43704      &  2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
43705      &  X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
43706      &  *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
43707      &  X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
43708      &  X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
43709      &  *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
43710         FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43711      &  4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43712      &  X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
43713      &  2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
43714      &  X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
43715      &  3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
43716      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
43717      &  X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
43718      &  *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
43719      &  X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
43720      &  X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
43721         FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
43722      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
43723      &  X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
43724         FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
43725      &  *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
43726      &  -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
43727      &  -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
43728      &  7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
43729      &  *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
43730      &  *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
43731      &  **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
43732      &  2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
43733         FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
43734      &  *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
43735      &  X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
43736      &  X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
43737      &  *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
43738      &  X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
43739         FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
43740      &  X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
43741      &  X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43742      &  *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43743      &  *X6)
43744         FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43745      &  10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43746      &  X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43747      &  X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43748      &  X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43749      &  +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43750      &  7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43751         FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43752      &  *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43753      &  *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43754      &  X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43755      &  X8)
43756         FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43757      &  X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43758      &  )+2*X2*(-X10*X5+X9*X6+X8*X7)
43759         FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43760      &  X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43761      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43762      &  X9*X5)
43763         FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43764      &  X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43765      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43766      &  X8*X5)
43767         FM(9,10)=0.5D0*(FMXX+FM(9,10))
43768         FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43769      &  X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43770      &  )+2*X5*(-X10*X2+X9*X3+X8*X4)
43771  
43772 C...Repackage matrix elements.
43773         DO 200 I=1,8
43774           DO 190 J=I,8
43775             RM(I,J)=FM(I,J)
43776   190     CONTINUE
43777   200   CONTINUE
43778         RM(7,7)=FM(7,7)-2D0*FM(9,9)
43779         RM(7,8)=FM(7,8)-2D0*FM(9,10)
43780         RM(8,8)=FM(8,8)-2D0*FM(10,10)
43781  
43782 C...Produce final result: matrix elements * colours * propagators.
43783         DO 220 I=1,8
43784           DO 210 J=I,8
43785             FAC=8D0
43786             IF(I.EQ.J)FAC=4D0
43787             WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43788   210     CONTINUE
43789   220   CONTINUE
43790         WTQQBH=-WTQQBH/256D0
43791  
43792       ELSE
43793 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43794         A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43795      &  *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43796      &  *X6+X8*X7)
43797         A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43798      &  2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43799      &  +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43800      &  X5)
43801         A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43802      &  X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43803      &  *X9+X4*X8)
43804  
43805 C...Produce final result: matrix elements * propagators.
43806         A11=A11/DX(7)**2
43807         A12=A12/(DX(7)*DX(8))
43808         A22=A22/DX(8)**2
43809         WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43810       ENDIF
43811  
43812       RETURN
43813       END
43814  
43815 C*********************************************************************
43816  
43817 C...PYSTBH (and auxiliaries)
43818 C.. Evaluates the matrix elements for t + b + H production.
43819  
43820       SUBROUTINE PYSTBH(WTTBH)
43821  
43822 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43823       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43824       IMPLICIT INTEGER(I-N)
43825       INTEGER PYK,PYCHGE,PYCOMP
43826  
43827 C...COMMONBLOCKS
43828       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43829       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43830       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43831       COMMON/PYINT1/MINT(400),VINT(400)
43832       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43833       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43834       COMMON/PYINT4/MWID(500),WIDS(500,5)
43835       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43836       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43837       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43838      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43839      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43840      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43841       COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43842       DOUBLE PRECISION MW2
43843       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43844      &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43845  
43846 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43847       DIMENSION QQ(4,2),PP(4,3)
43848       DATA QQ/8*0D0/
43849  
43850       WTTBH=0D0
43851  
43852 C...KINEMATIC PARAMETERS.
43853       SHPR=SQRT(VINT(26))*VINT(1)
43854       PH=SQRT(VINT(21))*VINT(1)
43855       SPH=PH**2
43856  
43857 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43858       DO 100 I=1,2
43859         PT=SQRT(MAX(0D0,VINT(197+5*I)))
43860         PP(1,I)=PT*COS(VINT(198+5*I))
43861         PP(2,I)=PT*SIN(VINT(198+5*I))
43862   100 CONTINUE
43863       PP(1,3)=-PP(1,1)-PP(1,2)
43864       PP(2,3)=-PP(2,1)-PP(2,2)
43865       PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43866       PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43867       PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43868       PMT3=SQRT(PMS3)
43869       PP(3,3)=PMT3*SINH(VINT(211))
43870       PP(4,3)=PMT3*COSH(VINT(211))
43871       PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43872       PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43873      &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43874       PP(3,2)=-PP(3,1)-PP(3,3)
43875       PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43876       PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43877  
43878 C...CM SYSTEM, INGOING QUARKS/GLUONS
43879       QQ(3,1) = SHPR/2.D0
43880       QQ(4,1) = QQ(3,1)
43881       QQ(3,2) = -QQ(3,1)
43882       QQ(4,2) = QQ(4,1)
43883  
43884 C...PARAMETERS FOR AMPLITUDE METHOD
43885       ALPHA = AEM
43886       ALPHAS = AS
43887       SW2 = PARU(102)
43888       MW2 = PMAS(24,1)**2
43889       TANB = PARU(141)
43890       VTB = VCKM(3,3)
43891       RMB=PYMRUN(5,VINT(52))
43892  
43893       ISUB=MINT(1)
43894  
43895       IF (ISUB.EQ.401) THEN
43896         CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43897      &  VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43898       ELSE IF (ISUB.EQ.402) THEN
43899         CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43900      &  VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43901       END IF
43902  
43903       RETURN
43904       END
43905 C------------------------------------------------------------------
43906       SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43907 C  WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43908       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43909       IMPLICIT INTEGER(I-N)
43910       DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43911       COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43912       SAVE /PYCTBH/
43913  
43914 C   TOP WIDTH CALCULATION
43915 C       VTB  = 0.99
43916       MW=DSQRT(MW2)
43917       XB=(MB/MT)**2
43918       XW=(MW/MT)**2
43919       XH =(MHP/MT)**2
43920       GAMTBH = 0D0
43921       IF (MT .LT. (MHP+MB)) THEN
43922 C  T ->B W ONLY
43923          BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43924          GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43925      &        (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43926          GAMT  = GAMTBW
43927       ELSE
43928 C T ->BW +T ->B H^+
43929          BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43930          GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43931      &        (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43932 C
43933          KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43934      &        -4.D0*(MHP*MB/MT**2)**2 )
43935          GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43936      &        (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43937          GAMT  = GAMTBW+GAMTBH
43938       ENDIF
43939 C THUS BR IS
43940       BR=GAMTBH/GAMT
43941       RETURN
43942       END
43943  
43944 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43945 C GG->TBH^+, QQBAR->TBH^+
43946 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43947 C (FOR INSTANCE WITH PYTHIA)
43948 C------------------------------------------------------------
43949 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY  HEP-PH/9905443,
43950 C PHYS REV. D 60 (1999) 115011
43951 C (THESE FILES PREPARED BY J.-L. KNEUR)
43952 C------------------------------------------------------------
43953 C 1)  GG->TBH^+
43954        SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43955 C
43956 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43957 C
43958 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43959 C        P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43960 C        P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43961 C  (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43962 C "PHYSICAL PARAMETERS" INPUT:
43963 C        MT,MB TOP AND BOTTOM MASSES;
43964 C        MHP CHARGED HIGGS MASS
43965 C   FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43966 C
43967 C OUTPUT: AMP2  IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43968 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43969 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43970 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43971 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43972 C   SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43973 C           STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43974 C
43975       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43976       IMPLICIT INTEGER(I-N)
43977       DOUBLE PRECISION MW2,MT,MB,MHP,MW
43978       DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43979       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43980       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43981       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43982  
43983       COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43984       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43985 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43986 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43987 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43988 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43989 C (TAN BETA) VALUES
43990 C
43991 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43992 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43993  
43994       PI = 4*DATAN(1.D0)
43995       MW = DSQRT(MW2)
43996 C
43997 C COLLECTING THE RELEVANT OVERALL FACTORS:
43998 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43999       PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
44000 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44001       FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44002 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44003 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44004 C ALPHAS IS ALPHA_STRONG;
44005 C SW2 IS SIN(THETA_W)**2.
44006 C
44007 C      VTB=.998D0
44008 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44009 C
44010       V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44011       A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44012 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44013 C
44014 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44015 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44016       DO 100 KK=1,4
44017       P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44018   100 CONTINUE
44019 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44020       S = 2*PYTBHS(Q1,Q2)
44021       P1Q1=PYTBHS(Q1,P1)
44022       P1Q2=PYTBHS(P1,Q2)
44023       P2Q1=PYTBHS(P2,Q1)
44024       P2Q2=PYTBHS(P2,Q2)
44025       P1P2=PYTBHS(P1,P2)
44026 C
44027 C   TOP WIDTH CALCULATION
44028       CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44029 C   GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44030 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44031       A1INV= S -2*P1Q1 -2*P1Q2
44032       A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44033 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44034 C  NB:    A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
44035 C  THE TOP WIDTH
44036       A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44037       A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44038 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44039 C  NOW COMES THE AMP**2:
44040 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
44041 C THE EXPRESSIONS BELOW
44042       V18=0.D0
44043       A18=0.D0
44044       V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
44045      &512*A1*A2*MB*MT/3-
44046      &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44047      &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
44048      &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
44049      &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44050      &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
44051      &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
44052      &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
44053      &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
44054      &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44055      &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44056      &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
44057      &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
44058      &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44059      &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44060      &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
44061       V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
44062      &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
44063      &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
44064      &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44065      &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
44066      &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
44067      &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44068      &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44069      &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44070      &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
44071      &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44072      &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44073      &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44074      &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44075      &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44076      &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
44077      &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44078       V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44079      &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
44080      &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
44081      &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44082      &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
44083      &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44084      &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44085      &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
44086      &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
44087      &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44088      &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
44089      &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44090      &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44091      &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44092      &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44093      &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
44094      &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
44095       V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44096      &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
44097      &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44098      &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44099      &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44100      &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44101      &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44102      &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
44103      &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
44104      &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
44105      &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44106      &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44107      &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44108      &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44109      &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44110      &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
44111      &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44112       V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44113      &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44114      &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
44115      &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44116      &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
44117      &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44118      &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44119      &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
44120      &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44121      &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44122      &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44123      &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
44124      &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44125      &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44126      &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44127      &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44128      &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44129       V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44130      &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
44131      &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44132      &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44133      &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
44134      &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44135      &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44136      &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44137      &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44138      &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44139      &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44140      &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
44141      &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44142      &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44143      &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44144      &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
44145      &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44146       V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44147      &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44148      &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44149      &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44150      &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
44151      &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44152      &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
44153      &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44154      &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
44155      &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
44156      &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44157      &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44158      &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44159      &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44160      &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
44161      &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44162      &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44163       V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44164      &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44165      &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44166      &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
44167      &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44168      &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44169      &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44170      &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44171      &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44172      &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
44173      &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
44174      &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44175      &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44176      &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44177      &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
44178      &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44179      &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44180       V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44181      &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44182      &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44183      &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
44184      &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44185      &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
44186      &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44187      &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44188      &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
44189      &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44190      &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44191      &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44192      &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44193      &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44194      &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
44195      &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44196      &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44197       V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44198      &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44199      &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44200      &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44201      &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44202      &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
44203      &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44204      &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44205      &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44206      &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44207      &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44208      &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
44209      &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44210      &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44211      &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44212      &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44213      &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44214       V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44215      &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
44216      &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44217      &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
44218      &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44219      &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44220      &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44221      &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44222      &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44223      &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44224      &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44225      &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44226      &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
44227      &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44228      &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44229      &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
44230      &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44231       V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44232      &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44233      &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44234      &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44235      &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
44236      &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44237      &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44238      &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44239      &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
44240      &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44241      &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44242      &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
44243      &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44244      &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44245      &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44246      &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44247      &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44248       V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44249      &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44250      &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44251      &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44252      &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44253      &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44254      &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44255      &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44256      &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44257      &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44258      &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44259      &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44260      &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44261      &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44262      &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
44263      &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44264      &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44265       V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44266      &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44267      &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44268      &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44269      &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44270      &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44271      &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
44272      &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44273      &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44274      &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44275      &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44276      &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44277      &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44278      &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44279      &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44280      &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
44281      &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44282       V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44283      &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44284      &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44285      &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44286      &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
44287      &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44288      &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44289      &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44290      &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44291      &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44292      &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44293      &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44294      &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44295      &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
44296      &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44297      &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44298      &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44299       V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44300      &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44301      &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44302      &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44303      &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44304      &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44305      &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44306      &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44307      &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44308      &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44309      &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44310      &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44311      &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44312      &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
44313      &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44314      &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44315      &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44316       V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
44317      &384*A12*MB*MT*P1Q1**2/S**2+
44318      &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44319      &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
44320      &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44321      &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44322      &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44323      &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44324      &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
44325      &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44326      &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44327      &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44328      &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44329      &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44330      &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44331      &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44332      &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44333      &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
44334       V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44335      &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
44336      &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
44337      &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
44338      &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
44339      &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
44340      &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44341      &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
44342      &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
44343      &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
44344      &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
44345      &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
44346      &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
44347      &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44348      &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
44349      &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44350      &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
44351       V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
44352      &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44353      &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44354      &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
44355      &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
44356      &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
44357      &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
44358      &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44359      &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44360      &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44361      &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44362      &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
44363      &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44364      &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
44365      &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
44366      &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
44367      &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
44368      &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
44369       V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44370      &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
44371      &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44372      &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44373      &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44374      &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44375      &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44376      &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44377      &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44378      &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44379      &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44380      &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44381      &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
44382      &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
44383      &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
44384      &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
44385      &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
44386       V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
44387      &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44388      &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44389      &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44390      &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
44391      &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44392      &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
44393      &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44394      &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44395      &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44396      &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44397      &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44398      &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44399      &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
44400      &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44401      &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
44402      &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44403      &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
44404       V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44405      &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44406      &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
44407      &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
44408      &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44409      &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44410      &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44411      &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44412      &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
44413      &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44414      &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
44415      &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44416      &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44417      &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44418      &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
44419      &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44420      &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
44421       V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44422      &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
44423      &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
44424      &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
44425      &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44426      &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
44427      &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
44428      &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44429      &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44430      &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44431      &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44432      &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44433      &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44434      &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44435      &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44436      &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44437      &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
44438       V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44439      &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44440      &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44441      &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44442      &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44443      &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44444      &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44445      &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44446      &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44447      &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
44448      &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44449      &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
44450      &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44451      &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44452      &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44453      &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44454      &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
44455       V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
44456      &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44457      &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
44458      &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
44459      &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44460      &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44461      &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
44462      &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44463      &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44464      &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
44465      &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44466      &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44467      &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44468      &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
44469      &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
44470      &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44471      &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
44472       V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
44473      &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44474      &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44475      &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44476      &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44477      &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44478      &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44479      &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
44480      &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
44481      &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
44482      &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44483      &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44484      &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44485      &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44486      &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44487      &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
44488      &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
44489       V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44490      &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44491      &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44492      &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
44493      &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
44494  
44495       V18BIS=
44496      &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44497      &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44498      &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44499      &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44500      &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44501      &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44502      &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44503      &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44504      &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44505      &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44506      &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
44507      &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44508      &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44509      &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
44510      &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44511      &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
44512       V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
44513      &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
44514      &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44515      &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44516      &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44517      &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44518      &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44519      &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44520      &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
44521      &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
44522      &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44523      &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44524      &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
44525      &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
44526      &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44527      &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
44528      &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
44529       V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
44530      &272*A1*A2*P1Q1*S/(3*P1Q2)+
44531      &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
44532      &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44533      &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
44534      &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44535      &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44536      &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44537      &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44538      &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44539      &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
44540      &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44541      &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44542      &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
44543      &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44544      &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
44545      &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
44546       V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44547      &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44548      &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
44549      &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
44550      &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
44551      &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44552      &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
44553      &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44554      &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
44555      &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44556      &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44557      &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
44558      &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44559      &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44560      &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
44561      &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44562      &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
44563       V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
44564      &32*A12*P2Q1*S/(3*P1Q1)-
44565      &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44566      &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
44567      &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
44568      &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44569      &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44570      &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44571      &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44572      &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44573      &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
44574      &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44575      &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44576      &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
44577      &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44578      &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44579      &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
44580       V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
44581      &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
44582      &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44583      &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
44584      &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44585      &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44586      &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
44587      &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44588      &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
44589      &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44590      &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
44591      &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44592      &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44593      &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44594      &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44595      &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44596      &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
44597       V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
44598      &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
44599      &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44600      &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
44601      &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
44602      &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
44603      &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44604      &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44605      &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44606      &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44607      &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44608      &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44609      &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44610      &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44611      &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44612      &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44613      &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
44614       V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
44615      &272*A1*A2*P2Q1*S/(3*P2Q2)-
44616      &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
44617      &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44618      &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
44619      &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44620      &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44621      &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44622      &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44623      &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44624      &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44625      &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44626      &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
44627      &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44628      &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44629      &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44630      &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
44631       V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
44632      &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44633      &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44634      &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
44635      &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
44636      &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44637      &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44638      &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44639 C
44640  
44641       A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
44642      &512*A1*A2*MB*MT/3+
44643      &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44644      &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
44645      &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
44646      &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44647      &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
44648      &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
44649      &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
44650      &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
44651      &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44652      &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44653      &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
44654      &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
44655      &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44656      &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44657      &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
44658       A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
44659      &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
44660      &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
44661      &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44662      &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
44663      &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
44664      &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44665      &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44666      &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44667      &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
44668      &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44669      &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44670      &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44671      &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44672      &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44673      &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
44674      &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44675       A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44676      &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
44677      &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
44678      &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44679      &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
44680      &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44681      &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44682      &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
44683      &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
44684      &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44685      &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
44686      &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44687      &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44688      &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44689      &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44690      &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
44691      &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
44692       A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44693      &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
44694      &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44695      &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44696      &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44697      &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44698      &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44699      &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
44700      &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
44701      &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
44702      &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44703      &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44704      &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44705      &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
44706      &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44707      &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
44708      &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44709       A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44710      &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44711      &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
44712      &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44713      &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
44714      &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44715      &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44716      &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44717      &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44718      &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44719      &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44720      &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
44721      &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44722      &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44723      &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
44724      &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44725      &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44726       A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44727      &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
44728      &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44729      &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44730      &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
44731      &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44732      &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44733      &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
44734      &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44735      &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44736      &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44737      &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
44738      &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44739      &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44740      &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44741      &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44742      &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44743       A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44744      &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44745      &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44746      &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44747      &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44748      &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44749      &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44750      &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44751      &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44752      &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44753      &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44754      &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44755      &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44756      &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44757      &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44758      &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44759      &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44760       A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44761      &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44762      &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44763      &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44764      &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44765      &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44766      &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44767      &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44768      &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44769      &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44770      &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44771      &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44772      &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44773      &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44774      &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44775      &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44776      &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44777       A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44778      &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44779      &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44780      &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44781      &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44782      &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44783      &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44784      &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44785      &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44786      &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44787      &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44788      &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44789      &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44790      &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44791      &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44792      &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44793      &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44794       A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44795      &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44796      &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44797      &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44798      &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44799      &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44800      &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44801      &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44802      &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44803      &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44804      &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44805      &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44806      &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44807      &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44808      &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44809      &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44810      &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44811       A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44812      &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44813      &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44814      &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44815      &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44816      &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44817      &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44818      &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44819      &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44820      &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44821      &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44822      &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44823      &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44824      &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44825      &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44826      &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44827      &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44828       A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44829      &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44830      &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44831      &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44832      &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44833      &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44834      &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44835      &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44836      &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44837      &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44838      &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44839      &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44840      &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44841      &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44842      &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44843      &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44844      &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44845       A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44846      &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44847      &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44848      &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44849      &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44850      &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44851      &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44852      &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44853      &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44854      &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44855      &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44856      &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44857      &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44858      &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44859      &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44860      &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44861      &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44862       A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44863      &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44864      &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44865      &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44866      &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44867      &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44868      &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44869      &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44870      &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44871      &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44872      &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44873      &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44874      &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44875      &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44876      &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44877      &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44878      &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44879       A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44880      &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44881      &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44882      &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44883      &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44884      &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44885      &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44886      &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44887      &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44888      &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44889      &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44890      &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44891      &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44892      &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44893      &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44894      &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44895      &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44896       A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44897      &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44898      &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44899      &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44900      &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44901      &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44902      &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44903      &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44904      &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44905      &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44906      &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44907      &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44908      &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44909      &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44910      &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44911      &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44912      &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44913       A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44914      &384*A12*MB*MT*P1Q1**2/S**2+
44915      &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44916      &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44917      &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44918      &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44919      &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44920      &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44921      &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44922      &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44923      &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44924      &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44925      &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44926      &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44927      &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44928      &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44929      &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44930       A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44931      &384*A2**2*MB*MT*P2Q2**2/S**2+
44932      &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44933      &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44934      &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44935      &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44936      &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44937      &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44938      &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44939      &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44940      &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44941      &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44942      &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44943      &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44944      &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44945      &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44946      &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44947       A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44948      &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44949      &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44950      &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44951      &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44952      &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44953      &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44954      &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44955      &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44956      &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44957      &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44958      &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44959      &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44960      &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44961      &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44962      &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44963      &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44964       A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44965      &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44966      &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44967      &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44968      &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44969      &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44970      &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44971      &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44972      &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44973      &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44974      &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44975      &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44976      &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44977      &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44978      &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44979      &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44980      &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44981       A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44982      &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44983      &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44984      &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44985      &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44986      &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44987      &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44988      &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44989      &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44990      &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44991      &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44992      &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44993      &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44994      &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44995      &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44996      &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44997      &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44998       A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44999      &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
45000      &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
45001      &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
45002      &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
45003      &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
45004      &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
45005      &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
45006      &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
45007      &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
45008      &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
45009      &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
45010      &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
45011      &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
45012      &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
45013      &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
45014      &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
45015       A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
45016      &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
45017      &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
45018      &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
45019      &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
45020      &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
45021      &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
45022      &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
45023      &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
45024      &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45025      &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45026      &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
45027      &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
45028      &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
45029      &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
45030      &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
45031      &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
45032       A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
45033      &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
45034      &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
45035      &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45036      &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45037      &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45038      &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45039      &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45040      &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
45041      &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
45042      &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
45043      &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
45044      &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
45045      &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
45046      &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
45047      &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
45048      &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
45049       A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
45050      &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
45051      &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
45052      &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
45053      &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
45054      &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
45055      &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
45056      &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
45057      &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
45058      &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
45059      &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
45060      &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
45061      &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
45062      &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
45063      &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
45064      &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
45065      &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
45066       A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
45067      &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
45068      &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
45069      &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
45070      &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
45071      &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45072      &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45073      &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
45074      &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
45075      &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
45076      &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
45077      &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
45078      &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
45079      &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
45080      &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
45081      &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
45082      &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
45083       A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
45084      &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45085      &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45086      &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
45087      &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45088      &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45089      &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45090      &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45091      &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45092      &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45093      &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
45094      &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
45095      &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
45096      &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
45097      &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
45098      &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
45099      &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
45100       A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
45101      &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
45102      &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
45103      &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
45104      &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
45105      &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
45106      &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
45107      &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45108      &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45109      &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
45110      &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
45111      &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
45112      &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
45113      &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
45114      &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
45115      &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
45116      &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
45117       A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
45118      &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
45119      &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
45120      &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
45121      &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
45122      &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
45123      &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
45124      &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
45125  
45126       A18BIS=
45127      &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
45128      &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
45129      &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
45130      &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
45131      &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
45132      &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
45133      &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
45134      &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
45135      &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
45136      &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
45137      &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
45138      &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
45139      &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
45140      &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
45141      &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
45142      &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
45143       A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
45144      &12*S/(P1Q2*P2Q1)+
45145      &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
45146      &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
45147      &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
45148      &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
45149      &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
45150      &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
45151      &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45152      &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45153      &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
45154      &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
45155      &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
45156      &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
45157      &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
45158      &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
45159      &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
45160       A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
45161      &32*MB**2*S/(3*P1Q1*P2Q2**2)+
45162      &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
45163      &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
45164      &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
45165      &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
45166      &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
45167      &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
45168      &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
45169      &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
45170      &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
45171      &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
45172      &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
45173      &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
45174      &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
45175      &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
45176      &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
45177       A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
45178      &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
45179      &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
45180      &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
45181      &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
45182      &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
45183      &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
45184      &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
45185      &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
45186      &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45187      &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45188      &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
45189      &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
45190      &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
45191      &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
45192      &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
45193      &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
45194       A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45195      &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45196      &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45197      &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45198      &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
45199      &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45200      &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45201      &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45202      &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45203      &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45204      &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45205      &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45206      &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
45207      &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
45208      &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
45209      &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
45210      &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
45211       A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
45212      &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
45213      &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
45214      &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
45215      &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
45216      &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
45217      &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
45218      &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
45219      &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
45220      &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
45221      &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
45222      &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
45223      &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
45224      &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
45225      &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
45226      &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
45227      &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
45228       A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
45229      &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
45230      &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
45231 C
45232       V18=V18+V18BIS
45233       A18=A18+A18BIS
45234       V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
45235      &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
45236      &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45237      &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45238      &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45239      &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
45240      &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45241      &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45242      &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45243      &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45244      &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45245      &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45246      &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
45247      &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
45248      &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
45249      &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
45250      &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
45251       V910=V910+96*A1*A2*P1P2*P2Q1/S-
45252      &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45253      &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
45254      &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
45255      &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45256      &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45257 C
45258       A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
45259      &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
45260      &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45261      &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45262      &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45263      &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
45264      &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45265      &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45266      &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
45267      &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45268      &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45269      &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45270      &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
45271      &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
45272      &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
45273      &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
45274      &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
45275       A910=A910+96*A1*A2*P1P2*P2Q1/S-
45276      &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45277      &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
45278      &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
45279      &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45280      &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45281 C
45282 C FINAL RESULT;
45283 C
45284       AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
45285  
45286       END
45287 C---------------------------------------------------------
45288 C 2)  Q QBAR ->TBH^+
45289        SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
45290 C
45291 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
45292 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
45293       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45294       IMPLICIT INTEGER(I-N)
45295       DOUBLE PRECISION MW2,MT,MB,MHP,MW
45296       DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
45297       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45298       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45299       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45300       COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
45301       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
45302 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
45303 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
45304 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
45305 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
45306 C
45307 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
45308 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
45309 C
45310       DIMENSION YY(2,2)
45311  
45312       PI = 4*DATAN(1.D0)
45313       MW = DSQRT(MW2)
45314  
45315 C COLLECTING THE RELEVANT OVERALL FACTORS:
45316 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
45317       PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
45318 C COUPLING CONSTANT (OVERALL NORMALIZATION)
45319       FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
45320 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
45321 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
45322 C ALPHAS IS ALPHA_STRONG;
45323 C SW2 IS SIN(THETA_W)**2.
45324 C
45325 C      VTB=.998D0
45326 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
45327 C
45328       V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
45329       A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
45330 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
45331 C
45332 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
45333 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
45334       DO 100 KK=1,4
45335         P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
45336   100 CONTINUE
45337 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
45338       S = 2*PYTBHS(Q1,Q2)
45339       P1Q1=PYTBHS(Q1,P1)
45340       P1Q2=PYTBHS(P1,Q2)
45341       P2Q1=PYTBHS(P2,Q1)
45342       P2Q2=PYTBHS(P2,Q2)
45343       P1P2=PYTBHS(P1,P2)
45344 C
45345 C   TOP WIDTH CALCULATION
45346       CALL PYTBHB(MT,MB,MHP,BR,GAMT)
45347 C   GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
45348 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
45349       A1INV= S -2*P1Q1 -2*P1Q2
45350       A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
45351 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
45352 C  NB  A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
45353       A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
45354       A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
45355 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
45356 C  NOW COMES THE AMP**2:
45357 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
45358 C THE EXPRESSIONS BELOW
45359       YY(1, 1) = -16*A**2*A2**2*MB*MT+
45360      &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
45361      &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
45362      &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
45363      &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45364      &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45365      &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
45366      &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
45367      &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
45368      &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
45369      &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
45370      &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
45371      &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
45372      &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
45373      &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45374      &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45375      &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
45376       YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
45377      &32*A2**2*MB**2*P1P2*V**2/S+
45378      &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
45379      &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
45380      &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
45381       YY(1, 1)=2*YY(1, 1)
45382  
45383       YY(1, 2) = -32*A**2*A1*A2*MB*MT+
45384      &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
45385      &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45386      &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45387      &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
45388      &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
45389      &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
45390      &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45391      &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
45392      &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45393      &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
45394      &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
45395      &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
45396      &64*A**2*A1*A2*MB*MT*P1P2/S+
45397      &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
45398      &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
45399      &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
45400       YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
45401      &64*A**2*A1*A2*P1Q1*P2Q1/S-
45402      &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
45403      &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
45404      &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
45405      &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
45406      &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
45407      &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
45408      &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
45409      &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
45410      &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
45411      &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
45412      &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
45413      &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45414      &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45415      &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
45416      &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
45417       YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
45418      &32*A1*A2*P1P2*P1Q1*V**2/S+
45419      &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
45420      &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
45421      &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
45422      &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
45423  
45424  
45425       YY(2, 2) =-16*A**2*A12*MB*MT+
45426      &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
45427      &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
45428      &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
45429      &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
45430      &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
45431      &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
45432      &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
45433      &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
45434      &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
45435      &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
45436      &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
45437      &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
45438      &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
45439      &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
45440      &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
45441      &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
45442       YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
45443      &32*A12*MT**2*P2Q2*V**2/S-
45444      &32*A12*P1Q2*P2Q2*V**2/S
45445       YY(2, 2)=2*YY(2, 2)
45446  
45447       RES=YY(1,1)+2*YY(1,2)+YY(2,2)
45448       AMP2=  FACT*PS*VTB**2*RES
45449  
45450       END
45451 C=====================================================================
45452 C     ************* FUNCTION SCALAR PRODUCTS *************************
45453       DOUBLE PRECISION FUNCTION PYTBHS(A,B)
45454       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45455       IMPLICIT INTEGER(I-N)
45456       DIMENSION A(4),B(4)
45457       DUM=A(4)*B(4)
45458       DO 100 ID=1,3
45459          DUM=DUM-A(ID)*B(ID)
45460   100 CONTINUE
45461       PYTBHS=DUM
45462       RETURN
45463       END
45464  
45465 C*********************************************************************
45466  
45467 C...PYMSIN
45468 C...Initializes supersymmetry: finds sparticle masses and
45469 C...branching ratios and stores this information.
45470 C...AUTHOR: STEPHEN MRENNA
45471 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
45472  
45473       SUBROUTINE PYMSIN
45474  
45475 C...Double precision and integer declarations.
45476       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45477       IMPLICIT INTEGER(I-N)
45478       INTEGER PYK,PYCHGE,PYCOMP
45479 C...Parameter statement to help give large particle numbers.
45480       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45481      &KEXCIT=4000000,KDIMEN=5000000)
45482 C...Commonblocks.
45483       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45484       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45485       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45486       COMMON/PYDAT4/CHAF(500,2)
45487       CHARACTER CHAF*16
45488       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45489       COMMON/PYINT4/MWID(500),WIDS(500,5)
45490       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45491       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45492       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45493      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45494       COMMON/PYHTRI/HHH(7)
45495       COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45496       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
45497      &/PYMSSM/,/PYMSRV/,/PYSSMT/
45498  
45499 C...Local variables.
45500       DOUBLE PRECISION ALFA,BETA
45501       DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
45502       INTEGER I,J,J1,I1,K1
45503       INTEGER KC,LKNT,IDLAM(400,3)
45504       DOUBLE PRECISION XLAM(0:400)
45505       DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
45506       DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
45507       DOUBLE PRECISION DELM,XMDIF
45508       DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
45509       DOUBLE PRECISION ARG,SGNMU,R
45510       INTEGER IMSSM
45511       INTEGER IRPRTY
45512       INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
45513       SAVE MWIDSU,MDCYSU
45514       DATA KFSUSY/
45515      &1000001,2000001,1000002,2000002,1000003,2000003,
45516      &1000004,2000004,1000005,2000005,1000006,2000006,
45517      &1000011,2000011,1000012,2000012,1000013,2000013,
45518      &1000014,2000014,1000015,2000015,1000016,2000016,
45519      &1000021,1000022,1000023,1000025,1000035,1000024,
45520      &1000037,1000039,     25,     35,     36,     37,
45521      &      6,     24,     45,     46,1000045, 9*0/
45522       DATA INIT/0/
45523  
45524 C...Automatically read QNUMBERS, MASS, and DECAY tables      
45525       IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
45526         NQNUM=0
45527         CALL PYSLHA(0,0,IFAIL)
45528         CALL PYSLHA(5,0,IFAIL)
45529       ENDIF
45530       IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
45531 
45532 C...Do nothing further if SUSY not requested
45533       IMSSM=IMSS(1)
45534       IF(IMSSM.EQ.0) RETURN
45535       
45536 C...Save copy of MWID(KC) and MDCY(KC,1) values before
45537 C...they are set to zero for the LSP.
45538       IF(INIT.EQ.0) THEN
45539         INIT=1
45540         DO 100 I=1,36
45541           KF=KFSUSY(I)
45542           KC=PYCOMP(KF)
45543           MWIDSU(I)=MWID(KC)
45544           MDCYSU(I)=MDCY(KC,1)
45545   100   CONTINUE
45546       ENDIF
45547  
45548 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
45549       DO 110 I=1,36
45550         KF=KFSUSY(I)
45551         KC=PYCOMP(KF)
45552         IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
45553           MWID(KC)=MWIDSU(I)
45554           MDCY(KC,1)=MDCYSU(I)
45555         ENDIF
45556   110 CONTINUE
45557  
45558 C...First part of routine: set masses and couplings.
45559  
45560 C...Reset mixing values in sfermion sector to pure left/right.
45561       DO 120 I=1,16
45562         SFMIX(I,1)=1D0
45563         SFMIX(I,4)=1D0
45564         SFMIX(I,2)=0D0
45565         SFMIX(I,3)=0D0
45566   120 CONTINUE
45567  
45568 C...Add NMSSM states if NMSSM switched on, and change old names.
45569       IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
45570 C...  Switch on NMSSM
45571         WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
45572  
45573         KFN=25
45574         KCN=KFN
45575         CHAF(KCN,1)='h_10'
45576         CHAF(KCN,2)=' '
45577  
45578         KFN=35
45579         KCN=KFN
45580         CHAF(KCN,1)='h_20'
45581         CHAF(KCN,2)=' '
45582  
45583         KFN=45
45584         KCN=KFN
45585         CHAF(KCN,1)='h_30'
45586         CHAF(KCN,2)=' '
45587  
45588         KFN=36
45589         KCN=KFN
45590         CHAF(KCN,1)='A_10'
45591         CHAF(KCN,2)=' '
45592  
45593         KFN=46
45594         KCN=KFN
45595         CHAF(KCN,1)='A_20'
45596         CHAF(KCN,2)=' '
45597  
45598         KFN=1000045
45599         KCN=PYCOMP(KFN)
45600         IF (KCN.EQ.0) THEN
45601           DO 123 KCT=100,MSTU(6)
45602             IF(KCHG(KCT,4).GT.100) KCN=KCT
45603  123      CONTINUE
45604           KCN=KCN+1
45605           KCHG(KCN,4)=KFN
45606           MSTU(20)=0
45607         ENDIF
45608 C...  Set stable for now
45609         PMAS(KCN,2)=1D-6
45610         MWID(KCN)=0
45611         MDCY(KCN,1)=0
45612         MDCY(KCN,2)=0
45613         MDCY(KCN,3)=0
45614         CHAF(KCN,1)='~chi_50'
45615         CHAF(KCN,2)=' '
45616       ENDIF
45617  
45618 C...Read spectrum from SLHA file.
45619       IF (IMSSM.EQ.11) THEN
45620         CALL PYSLHA(1,0,IFAIL)
45621       ENDIF
45622  
45623 C...Common couplings.
45624       TANB=RMSS(5)
45625       BETA=ATAN(TANB)
45626       COSB=COS(BETA)
45627       SINB=TANB*COSB
45628       COS2B=COS(2D0*BETA)
45629       ALFA=RMSS(18)
45630       XMW2=PMAS(24,1)**2
45631       XMZ2=PMAS(23,1)**2
45632       XW=PARU(102)
45633  
45634 C...Define sparticle masses for a general MSSM simulation.
45635       IF(IMSSM.EQ.1) THEN
45636         IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
45637         DO 130 I=1,5,2
45638           KC=PYCOMP(KSUSY1+I)
45639           PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
45640           KC=PYCOMP(KSUSY2+I)
45641           PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
45642           KC=PYCOMP(KSUSY1+I+1)
45643           PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
45644           KC=PYCOMP(KSUSY2+I+1)
45645           PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
45646   130   CONTINUE
45647         XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
45648         IF(XARG.LT.0D0) THEN
45649           WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45650      &    ' FROM THE SUM RULE. '
45651           WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
45652           RETURN
45653         ELSE
45654           XARG=SQRT(XARG)
45655         ENDIF
45656         DO 140 I=11,15,2
45657           PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
45658           PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
45659           PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45660           PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45661   140   CONTINUE
45662         IF(IMSS(8).EQ.1) THEN
45663           RMSS(13)=RMSS(6)
45664           RMSS(14)=RMSS(7)
45665         ENDIF
45666  
45667 C...Alternatively derive masses from SUGRA relations.
45668       ELSEIF(IMSSM.EQ.2) THEN
45669         RMSS(36)=RMSS(16)
45670         CALL PYAPPS
45671 C...Or use ISASUSY
45672       ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
45673         RMSS(36)=RMSS(16)
45674         CALL PYSUGI
45675         ALFA=RMSS(18)
45676         GOTO 170
45677       ELSE
45678         GOTO 170
45679       ENDIF
45680  
45681 C...Add in extra D-term contributions.
45682       IF(IMSS(7).EQ.1) THEN
45683         R=0.43D0
45684         DX=RMSS(23)
45685         DY=RMSS(24)
45686         DS=RMSS(25)
45687         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45688         WRITE(MSTU(11),*) 'C  NEW DTERMS ADDED TO SCALAR MASSES   '
45689         WRITE(MSTU(11),*) 'C   IN A U(B-L) THEORY                 '
45690         WRITE(MSTU(11),*) 'C   DX = ',DX
45691         WRITE(MSTU(11),*) 'C   DY = ',DY
45692         WRITE(MSTU(11),*) 'C   DS = ',DS
45693         WRITE(MSTU(11),*) 'C                                      '
45694         DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
45695         WRITE(MSTU(11),*) 'C   DY AT THE WEAK SCALE = ',DY
45696         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45697         DQ2=DY/6D0-DX/3D0-DS/3D0
45698         DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
45699         DD2=DY/3D0+DX-2D0*DS/3D0
45700         DL2=-DY/2D0+DX-2D0*DS/3D0
45701         DE2=DY-DX/3D0-DS/3D0
45702         DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
45703         DHD2=-DY/2D0-2D0*DX/3D0+DS
45704         DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
45705      &  /ABS(COS2B)
45706         DMA2 = 2D0*DMU2+DHU2+DHD2
45707         DO 150 I=1,5,2
45708           KC=PYCOMP(KSUSY1+I)
45709           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45710           KC=PYCOMP(KSUSY2+I)
45711           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
45712           KC=PYCOMP(KSUSY1+I+1)
45713           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45714           KC=PYCOMP(KSUSY2+I+1)
45715           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
45716   150   CONTINUE
45717         DO 160 I=11,15,2
45718           KC=PYCOMP(KSUSY1+I)
45719           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45720           KC=PYCOMP(KSUSY2+I)
45721           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
45722           KC=PYCOMP(KSUSY1+I+1)
45723           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45724   160   CONTINUE
45725         IF(RMSS(4)**2+DMU2.LT.0D0) THEN
45726           WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
45727           CALL PYSTOP(104)
45728         ENDIF
45729         SGNMU=SIGN(1D0,RMSS(4))
45730         RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
45731         ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
45732         RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
45733         ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
45734         RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
45735         ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
45736         RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
45737         ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
45738         RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
45739         ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
45740         RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
45741         IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45742           WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45743           CALL PYSTOP(104)
45744         ENDIF
45745         RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45746         RMSS(6)=SQRT(RMSS(6)**2+DL2)
45747         RMSS(7)=SQRT(RMSS(7)**2+DE2)
45748         WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45749         WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45750         WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45751         WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45752         WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45753       ENDIF
45754  
45755 C...Fix the third generation sfermions.
45756       CALL PYTHRG
45757  
45758 C...Fix the neutralino--chargino--gluino sector.
45759       CALL PYINOM
45760  
45761 C...Fix the Higgs sector.
45762       CALL PYHGGM(ALFA)
45763  
45764 C...Choose the Gunion-Haber convention.
45765       ALFA=-ALFA
45766       RMSS(18)=ALFA
45767  
45768 C...Print information on mass parameters.
45769       IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45770         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45771         WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45772         WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45773         WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45774         WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45775         WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45776         WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45777         WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45778         WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45779         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45780       ENDIF
45781       IF(IMSS(20).EQ.1) THEN
45782         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45783         WRITE(MSTU(11),*) ' DEBUG MODE '
45784         WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45785      &  UMIX(2,1),UMIX(2,2)
45786         WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45787      &  UMIXI(2,1),UMIXI(2,2)
45788         WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45789      &  VMIX(2,1),VMIX(2,2)
45790         WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45791      &  VMIXI(2,1),VMIXI(2,2)
45792         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45793         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45794         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45795         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45796         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45797         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45798         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45799         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45800         WRITE(MSTU(11),*) ' ALFA = ',ALFA
45801         WRITE(MSTU(11),*) ' BETA = ',BETA
45802         WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45803         WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45804         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45805       ENDIF
45806  
45807 C...Set up the Higgs couplings - needed here since initialization
45808 C...in PYINRE did not yet occur when PYWIDT is called below.
45809   170 AL=ALFA
45810       BE=BETA
45811       SINA=SIN(AL)
45812       COSA=COS(AL)
45813       COSB=COS(BE)
45814       SINB=TANB*COSB
45815       SBMA=SIN(BE-AL)
45816       SAPB=SIN(AL+BE)
45817       CAPB=COS(AL+BE)
45818       CBMA=COS(BE-AL)
45819       C2A=COS(2D0*AL)
45820       C2B=COSB**2-SINB**2
45821 C...tanb (used for H+)
45822       PARU(141)=TANB
45823  
45824 C...Firstly: h
45825 C...Coupling to d-type quarks
45826       PARU(161)=SINA/COSB
45827 C...Coupling to u-type quarks
45828       PARU(162)=-COSA/SINB
45829 C...Coupling to leptons
45830       PARU(163)=PARU(161)
45831 C...Coupling to Z
45832       PARU(164)=SBMA
45833 C...Coupling to W
45834       PARU(165)=PARU(164)
45835  
45836 C...Secondly: H
45837 C...Coupling to d-type quarks
45838       PARU(171)=-COSA/COSB
45839 C...Coupling to u-type quarks
45840       PARU(172)=-SINA/SINB
45841 C...Coupling to leptons
45842       PARU(173)=PARU(171)
45843 C...Coupling to Z
45844       PARU(174)=CBMA
45845 C...Coupling to W
45846       PARU(175)=PARU(174)
45847 C...Coupling to h
45848       IF(IMSS(4).GE.2) THEN
45849         PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45850       ELSE
45851         HHH(3)=HHH(3)+HHH(4)+HHH(5)
45852         PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45853      1  HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45854      2  2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45855      3  HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45856       ENDIF
45857 C...Coupling to H+
45858 C...Define later
45859       IF(IMSS(4).GE.2) THEN
45860         PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45861       ELSE
45862         PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45863      1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45864      2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45865      3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45866       ENDIF
45867 C...Coupling to A
45868       IF(IMSS(4).GE.2) THEN
45869         PARU(177)=COS(2D0*BE)*COS(BE+AL)
45870       ELSE
45871         PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45872      1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45873      2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45874      3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45875       ENDIF
45876 C...Coupling to H+
45877       IF(IMSS(4).GE.2) THEN
45878         PARU(178)=PARU(177)
45879       ELSE
45880         PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45881       ENDIF
45882 C...Thirdly, A
45883 C...Coupling to d-type quarks
45884       PARU(181)=TANB
45885 C...Coupling to u-type quarks
45886       PARU(182)=1D0/PARU(181)
45887 C...Coupling to leptons
45888       PARU(183)=PARU(181)
45889       PARU(184)=0D0
45890       PARU(185)=0D0
45891 C...Coupling to Z h
45892       PARU(186)=COS(BE-AL)
45893 C...Coupling to Z H
45894       PARU(187)=SIN(BE-AL)
45895       PARU(188)=0D0
45896       PARU(189)=0D0
45897       PARU(190)=0D0
45898  
45899 C...Finally: H+
45900 C...Coupling to W h
45901       PARU(195)=COS(BE-AL)
45902  
45903 C...Tell that all Higgs couplings have been set.
45904       MSTP(4)=1
45905  
45906 C...Set R-Violating couplings.
45907 C...Set lambda couplings to common value or "natural values".
45908       IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45909         VIR3=1D0/(126D0)**3
45910         DO 200 IRK=1,3
45911           DO 190 IRI=1,3
45912             DO 180 IRJ=1,3
45913               IF (IRI.NE.IRJ) THEN
45914                 IF (IRI.LT.IRJ) THEN
45915                   RVLAM(IRI,IRJ,IRK)=RMSS(51)
45916                   IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45917      &              SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45918      &              PMAS(9+2*IRK,1)*VIR3)
45919                 ELSE
45920                   RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45921                 ENDIF
45922               ELSE
45923                 RVLAM(IRI,IRJ,IRK)=0D0
45924               ENDIF
45925   180       CONTINUE
45926   190     CONTINUE
45927   200   CONTINUE
45928       ENDIF
45929 C...Set lambda' couplings to common value or "natural values".
45930       IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45931         VIR3=1D0/(126D0)**3
45932         DO 230 IRI=1,3
45933           DO 220 IRJ=1,3
45934             DO 210 IRK=1,3
45935               RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45936               IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45937      &          SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45938      &          PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45939   210       CONTINUE
45940   220     CONTINUE
45941   230   CONTINUE
45942       ENDIF
45943 C...Set lambda'' couplings to common value or "natural values".
45944       IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45945         VIR3=1D0/(126D0)**3
45946         DO 260 IRI=1,3
45947           DO 250 IRJ=1,3
45948             DO 240 IRK=1,3
45949               IF (IRJ.NE.IRK) THEN
45950                 IF (IRJ.LT.IRK) THEN
45951                   RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45952                   IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45953      &              RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45954      &              PMAS(2*IRK-1,1)*VIR3)
45955                 ELSE
45956                   RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45957                 ENDIF
45958               ELSE
45959                 RVLAMB(IRI,IRJ,IRK) = 0D0
45960               ENDIF
45961   240       CONTINUE
45962   250     CONTINUE
45963   260   CONTINUE
45964       ENDIF
45965  
45966 C...Antisymmetrize couplings set by user
45967       IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45968         DO 290 IRI=1,3
45969           DO 280 IRJ=1,3
45970             DO 270 IRK=1,3
45971               IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45972                 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45973                 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45974               ENDIF
45975               IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45976                 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45977                 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45978               ENDIF
45979   270       CONTINUE
45980   280     CONTINUE
45981   290   CONTINUE
45982       ENDIF
45983  
45984 C...Write spectrum to SLHA file
45985       IF (IMSS(23).NE.0) THEN
45986         IFAIL=0
45987         CALL PYSLHA(3,0,IFAIL)
45988       ENDIF
45989  
45990 C...Second part of routine: set decay modes and branching ratios.
45991  
45992 C...Allow chi10 -> gravitino + gamma or not.
45993       KC=PYCOMP(KSUSY1+39)
45994       IF( IMSS(11) .NE. 0 ) THEN
45995         PMAS(KC,1)=RMSS(21)/1D9
45996         PMAS(KC,2)=0D0
45997         IRPRTY=0
45998         WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45999       ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
46000         IRPRTY=0
46001         IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
46002      &       ' ALLOWING SUSY LLE DECAYS'
46003         IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
46004      &       ' ALLOWING SUSY LQD DECAYS'
46005         IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
46006      &       ' ALLOWING SUSY UDD DECAYS'
46007         IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
46008      &   ' --- Warning: R-Violating couplings possibly',
46009      &       ' incompatible with proton decay'
46010       ELSE
46011         PMAS(KC,1)=9999D0
46012         IRPRTY=1
46013       ENDIF
46014  
46015 C...Loop over sparticle and Higgs species.
46016       PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
46017 C...Find the LSP or NLSP for a gravitino LSP
46018       ILSP=0
46019       PMLSP=1D20
46020       DO 300 I=1,36
46021         KF=KFSUSY(I)
46022         IF(KF.EQ.1000039) GOTO 300
46023         KC=PYCOMP(KF)
46024         IF(PMAS(KC,1).LT.PMLSP) THEN
46025           ILSP=I
46026           PMLSP=PMAS(KC,1)
46027         ENDIF
46028   300 CONTINUE
46029       DO 370 I=1,50
46030         IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
46031         KF=KFSUSY(I)
46032         IF (KF.EQ.0) GOTO 370
46033         KC=PYCOMP(KF)
46034         LKNT=0
46035  
46036 C...Check if there are any decays listed for this sparticle
46037 C...in a file
46038         IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
46039           IFAIL=0
46040           CALL PYSLHA(2,KF,IFAIL)
46041           IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
46042         ELSEIF (I.GE.37) THEN
46043           GOTO 370
46044         ENDIF
46045  
46046 C...Sfermion decays.
46047         IF(I.LE.24) THEN
46048 C...First check to see if sneutrino is lighter than chi10.
46049           IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
46050      &    PMAS(KC,1).LT.PMCHI1) THEN
46051           ELSE
46052             CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
46053           ENDIF
46054  
46055 C...Gluino decays.
46056         ELSEIF(I.EQ.25) THEN
46057           CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
46058           IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
46059  
46060 C...Neutralino decays.
46061         ELSEIF(I.GE.26.AND.I.LE.29) THEN
46062           CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
46063 C...chi10 stable or chi10 -> gravitino + gamma.
46064           IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
46065             PMAS(KC,2)=1D-6
46066             MDCY(KC,1)=0
46067             MWID(KC)=0
46068           ENDIF
46069  
46070 C...Chargino decays.
46071         ELSEIF(I.GE.30.AND.I.LE.31) THEN
46072           CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
46073  
46074 C...Gravitino is stable.
46075         ELSEIF(I.EQ.32) THEN
46076           MDCY(KC,1)=0
46077           MWID(KC)=0
46078  
46079 C...Higgs decays.
46080         ELSEIF(I.GE.33.AND.I.LE.36) THEN
46081 C...Calculate decays to non-SUSY particles.
46082           CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
46083           LKNT=0
46084           DO 310 I1=0,100
46085             XLAM(I1)=0D0
46086   310     CONTINUE
46087           DO 330 I1=1,MDCY(KC,3)
46088             K1=MDCY(KC,2)+I1-1
46089             IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
46090      &      IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
46091             XLAM(I1)=WDTP(I1)
46092             XLAM(0)=XLAM(0)+XLAM(I1)
46093             DO 320 J1=1,3
46094               IDLAM(I1,J1)=KFDP(K1,J1)
46095   320       CONTINUE
46096             LKNT=LKNT+1
46097   330     CONTINUE
46098 C...Add the decays to SUSY particles.
46099           CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
46100         ENDIF
46101 C...Zero the branching ratios for use in loop mode
46102 C...thanks to K. Matchev (FNAL)
46103         DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46104           BRAT(IDC)=0D0
46105   340   CONTINUE
46106  
46107 C...Set stable particles.
46108         IF(LKNT.EQ.0) THEN
46109           MDCY(KC,1)=0
46110           MWID(KC)=0
46111           PMAS(KC,2)=1D-6
46112           PMAS(KC,3)=1D-5
46113           PMAS(KC,4)=0D0
46114  
46115 C...Store branching ratios in the standard tables.
46116         ELSE
46117           IDC=MDCY(KC,2)+MDCY(KC,3)-1
46118           DELM=1D6
46119           DO 360 IL=1,LKNT
46120             IDCSV=IDC
46121   350       IDC=IDC+1
46122             BRAT(IDC)=0D0
46123             IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
46124             IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
46125      &      KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
46126               BRAT(IDC)=XLAM(IL)/XLAM(0)
46127               XMDIF=PMAS(KC,1)
46128               IF(MDME(IDC,1).GE.1) THEN
46129                 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
46130      &          PMAS(PYCOMP(KFDP(IDC,2)),1)
46131                 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
46132      &          PMAS(PYCOMP(KFDP(IDC,3)),1)
46133               ENDIF
46134               IF(I.LE.32) THEN
46135                 IF(XMDIF.GE.0D0) THEN
46136                   DELM=MIN(DELM,XMDIF)
46137                 ELSE
46138                   WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
46139                   WRITE(MSTU(11),*) ' KF = ',KF
46140                   WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
46141                 ENDIF
46142               ENDIF
46143               GOTO 360
46144             ELSEIF(IDC.EQ.IDCSV) THEN
46145               WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
46146      &        'channel not recognized:'
46147               WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
46148               GOTO 360
46149             ELSE
46150               GOTO 350
46151             ENDIF
46152   360     CONTINUE
46153  
46154 C...Store width, cutoff and lifetime.
46155           PMAS(KC,2)=XLAM(0)
46156           IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
46157             PMAS(KC,3)=PMAS(KC,2)*10D0
46158           ELSE
46159             PMAS(KC,3)=0.95D0*DELM
46160           ENDIF
46161           IF(PMAS(KC,2).NE.0D0) THEN
46162             PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
46163           ENDIF
46164 C...Write decays to SLHA file
46165           IF (IMSS(24).NE.0) THEN
46166             IFAIL=0
46167             CALL PYSLHA(4,KF,IFAIL)
46168           ENDIF
46169  
46170         ENDIF
46171   370 CONTINUE
46172  
46173       RETURN
46174       END
46175 C*********************************************************************
46176  
46177 C...PYSLHA
46178 C...Read/write spectrum or decay data from SLHA standard file(s).
46179 C...P. Skands
46180 C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
46181 
46182 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
46183 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
46184 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
46185 C...          (KFORIG=0 : read all decay tables)
46186 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
46187 C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
46188 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
46189 C...          (KFORIG=0 : read all MASS entries)
46190  
46191       SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
46192  
46193 C...Double precision and integer declarations.
46194       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46195       IMPLICIT INTEGER(I-N)
46196       INTEGER PYK,PYCHGE,PYCOMP
46197       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46198      &KEXCIT=4000000,KDIMEN=5000000)
46199 C...Commonblocks.
46200       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46201       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46202       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
46203       COMMON/PYDAT4/CHAF(500,2)
46204       CHARACTER CHAF*16
46205       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46206       CHARACTER*40 ISAVER,VISAJE
46207       COMMON/PYINT4/MWID(500),WIDS(500,5)
46208       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
46209 C...SUSY blocks
46210       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46211       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46212      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46213       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
46214       SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
46215  
46216 C...Local arrays, character variables and data.
46217       COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46218      &     AU(3,3),AD(3,3),AE(3,3)
46219       COMMON/PYLH3C/CPRO(2),CVER(2)
46220 C...The common block of new states (QNUMBERS / PARTICLE)
46221       COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
46222 C...- NQNUM : Number of QNUMBERS blocks that have been read in
46223 C...- KQNUM(I,0) : KF of new state
46224 C...- KQNUM(I,1) : 3 times electric charge
46225 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
46226 C...- KQNUM(I,3) : Colour rep  (1: singlet, 3: triplet, 8: octet)
46227 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
46228 C...- KQNUM(I,5:9) : space available for further quantum numbers
46229       DIMENSION MMOD(100),MSPC(100),KFDEC(100)
46230       SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
46231 C...MMOD: flags to set for each block read in.
46232 C... 1: MODSEL     2: MINPAR     3: EXTPAR     4: SMINPUTS
46233 C...MSPC: Flags to set for each block read in.
46234 C... 1: MASS       2: NMIX       3: UMIX       4: VMIX       5: SBOTMIX
46235 C... 6: STOPMIX    7: STAUMIX    8: HMIX       9: GAUGE     10: AU
46236 C...11: AD        12: AE        13: YU        14: YD        15: YE
46237 C...16: SPINFO    17: ALPHA     18: MSOFT     19: QNUMBERS
46238       CHARACTER CPRO*12,CVER*12,CHNLIN*6
46239       CHARACTER DOC*11, CHDUM*120, CHBLCK*60
46240       CHARACTER CHINL*120,CHKF*9,CHTMP*16
46241       INTEGER VERBOS
46242       SAVE VERBOS
46243 C...Date of last Change
46244       PARAMETER (DOC='26 Feb 2013')
46245 C...Local arrays and initial values
46246       DIMENSION IDC(5),KFSUSY(50)
46247       SAVE KFSUSY
46248       DATA NQNUM /0/
46249       DATA NDECAY /0/
46250       DATA VERBOS /1/
46251       DATA NHELLO /0/
46252       DATA MLHEF /0/
46253       DATA MLHEFD /0/
46254       DATA KFSUSY/
46255      &1000001,1000002,1000003,1000004,1000005,1000006,
46256      &2000001,2000002,2000003,2000004,2000005,2000006,
46257      &1000011,1000012,1000013,1000014,1000015,1000016,
46258      &2000011,2000012,2000013,2000014,2000015,2000016,
46259      &1000021,1000022,1000023,1000025,1000035,1000024,
46260      &1000037,1000039,     25,     35,     36,     37,
46261      &      6,     24,     45,     46,1000045, 9*0/
46262       DATA KFDEC/100*0/
46263       RMFUN(IP)=PMAS(PYCOMP(IP),1)
46264       
46265 C...Shorthand for spectrum and decay table unit numbers
46266       IMSS21=IMSS(21)
46267       IMSS22=IMSS(22)
46268  
46269 C...Default for LHEF input: read header information
46270       IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
46271       IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
46272       IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
46273       IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
46274  
46275 C...Hello World
46276       IF (NHELLO.EQ.0) THEN
46277         IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
46278           WRITE(MSTU(11),5000) DOC
46279           NHELLO=1
46280         ENDIF
46281       ENDIF
46282  
46283 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
46284 C...+MUPDA).
46285       LFN=IMSS21
46286       IF (MUPDA.EQ.2) LFN=IMSS22
46287       IF (MUPDA.EQ.3) LFN=IMSS(23)
46288       IF (MUPDA.EQ.4) LFN=IMSS(24)
46289 C...Flag that we have not yet found whatever we were asked to find.
46290       IRETRN=1
46291 C...Flag that we are skipping until <slha> tag found (if LHEF)
46292       ISKIP=0
46293       IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
46294  
46295 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46296       IF (LFN.EQ.0) THEN
46297         WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
46298         GOTO 9999
46299       ENDIF
46300  
46301 C...If reading LHEF header, start by rewinding file
46302       IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
46303  
46304 C...If told to read spectrum, first zero all previous information.
46305       IF (MUPDA.EQ.1) THEN
46306 C...Zero all block read flags
46307         DO 100 M=1,100
46308           MMOD(M)=0
46309           MSPC(M)=0
46310   100   CONTINUE
46311 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
46312         DO 110 ISUSY=1,36
46313           KC=PYCOMP(KFSUSY(ISUSY))
46314           PMAS(KC,1)=0D0
46315   110   CONTINUE
46316 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
46317         DO 130 J=1,4
46318           SFMIX(5,J) =0D0
46319           SFMIX(6,J) =0D0
46320           SFMIX(15,J)=0D0
46321           DO 120 L=1,4
46322             ZMIX(L,J) =0D0
46323             ZMIXI(L,J)=0D0
46324             IF (J.LE.2.AND.L.LE.2) THEN
46325               UMIX(L,J) =0D0
46326               UMIXI(L,J)=0D0
46327               VMIX(L,J) =0D0
46328               VMIXI(L,J)=0D0
46329             ENDIF
46330   120     CONTINUE
46331 C...Zero signed masses.
46332           SMZ(J)=0D0
46333           IF (J.LE.2) SMW(J)=0D0
46334   130   CONTINUE
46335  
46336 C...If reading decays, reset PYTHIA decay counters.
46337       ELSEIF (MUPDA.EQ.2) THEN
46338 C...Check if DECAY for this KF already read
46339         IF (KFORIG.NE.0) THEN
46340           DO 140 IDEC=1,NDECAY
46341             IF (KFORIG.EQ.KFDEC(IDEC)) THEN
46342               IRETRN=0
46343               RETURN
46344             ENDIF
46345   140     CONTINUE
46346         ENDIF
46347         KCC=100
46348         NDC=0
46349         BRSUM=0D0
46350         DO 150 KC=1,MSTU(6)
46351           IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
46352           NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
46353   150   CONTINUE
46354       ELSEIF (MUPDA.EQ.5) THEN
46355 C...Zero block read flags
46356         DO 160 M=1,100
46357           MSPC(M)=0
46358   160   CONTINUE
46359       ENDIF
46360  
46361 C............READ
46362 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
46363       IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
46364 C...Initialize program and version strings
46365         IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
46366         CPRO(MUPDA)=' '
46367         CVER(MUPDA)=' '
46368         ENDIF
46369  
46370 C...Initialize read loop
46371         MERR=0
46372         NLINE=0
46373         CHBLCK=' '
46374 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
46375   170   CHINL=' '
46376         READ(LFN,'(A120)',END=400) CHINL
46377 C...Count which line number we're at.
46378         NLINE=NLINE+1
46379         WRITE(CHNLIN,'(I6)') NLINE
46380  
46381 C...Skip comment and empty lines without processing.
46382         IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
46383  
46384 C...We assume all upper case below. Rewrite CHINL to all upper case.
46385         INL=0
46386         IGOOD=0
46387   180   INL=INL+1
46388         IF (CHINL(INL:INL).NE.'#') THEN
46389           DO 190 ICH=97,122
46390             IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
46391   190     CONTINUE
46392 C...Extra safety. Chek for sensible input on line
46393           IF (IGOOD.EQ.0) THEN
46394             DO 200 ICH=48,90
46395               IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
46396   200       CONTINUE
46397           ENDIF
46398           IF (INL.LT.120) GOTO 180
46399         ENDIF
46400         IF (IGOOD.EQ.0) GOTO 170
46401  
46402 C...If reading from LHEF file, skip until <slha> begin tag found
46403         IF (ISKIP.NE.0) THEN 
46404           DO 205 I1=1,10
46405             IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
46406  205      CONTINUE        
46407           IF (ISKIP.NE.0) GOTO 170
46408         ENDIF
46409 
46410 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
46411         DO 210 I1=1,10          
46412           IF (CHINL(I1:I1+5).EQ.'</SLHA'
46413      &        .OR.CHINL(I1:I1+5).EQ.'<EVENT' 
46414      &        .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
46415             REWIND(LFN)
46416             GOTO 400
46417           ENDIF
46418   210   CONTINUE
46419  
46420 C...Check for BLOCK begin statement (spectrum).
46421         IF (CHINL(1:5).EQ.'BLOCK') THEN
46422           MERR=0
46423           READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
46424 C...Check if another of this type of block was already read.
46425 C...(logarithmic interpolation not yet implemented, so duplicates always
46426 C...give errors)
46427           IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
46428           IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
46429           IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
46430           IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
46431           IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
46432           IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
46433           IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
46434           IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
46435           IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
46436           IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
46437           IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
46438           IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
46439           IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
46440           IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
46441           IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
46442           IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
46443           IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
46444 C...Check for new particles
46445           IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46446      &        THEN
46447             MSPC(19)=MSPC(19)+1
46448 C...Read PDG code
46449             READ(CHBLCK(9:60),*) KFQ
46450  
46451             DO 220 MQ=1,NQNUM
46452               IF (KQNUM(MQ,0).EQ.KFQ) THEN
46453                 MERR=17
46454                 GOTO 380
46455               ENDIF
46456   220       CONTINUE
46457             IF (NHELLO.EQ.0) THEN
46458               WRITE(MSTU(11),5000) DOC
46459               NHELLO=1
46460             ENDIF
46461             NQNUM=NQNUM+1
46462             KQNUM(NQNUM,0)=KFQ
46463             MSPC(19)=MSPC(19)+1
46464             KCQ=PYCOMP(KFQ)
46465 C...Only read in new codes (also OK to overwrite if KF > 3000000)
46466             IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
46467               IF (KCQ.EQ.0) THEN
46468                 DO 230 KCT=100,MSTU(6)
46469                   IF(KCHG(KCT,4).GT.100) KCQ=KCT
46470   230           CONTINUE
46471                 KCQ=KCQ+1
46472               ENDIF
46473 C...More than 25 new QNUMBERS: fill up empty space before UED
46474               IF (KCQ.GT.500) THEN
46475                 KCQ=0
46476                 DO 235 KCT=100,450
46477                   IF(KCHG(KCT,4).GT.100) KCQ=KCT
46478   235           CONTINUE
46479                 KCQ=KCQ+1
46480                 IF (KCQ.EQ.451) THEN
46481                   WRITE(MSTU(11),*)
46482      &                 '* (PYSLHA:) Warning: too many QNUMBERS. ',
46483      &                 'Starting overwrite of UED particles.'
46484                 ELSE IF (KCQ.EQ.476) THEN
46485                   WRITE(MSTU(11),*)
46486      &                 '* (PYSLHA:) Error: too many QNUMBERS. ',
46487      &                 'Ran out of space, sorry! Try Pythia 8.'
46488                   KCQ = 501
46489                 ENDIF
46490               ENDIF
46491 C...End of special case for more than 25 new QNUMERS
46492               IF (KCQ.LE.500) THEN 
46493                 WRITE(MSTU(11),'(A,I9,A,I4,A)')
46494      &               ' * (PYSLHA:) Reading  '//CHBLCK(1:8)//
46495      &               '    for KF =',KFQ,'    (assigned KC',KCQ,')'
46496                 KCC=KCQ
46497                 KCHG(KCQ,4)=KFQ
46498 C...  First write PDG code as name
46499                 WRITE(CHTMP,*) KFQ
46500                 WRITE(CHTMP,'(A)') CHTMP(2:10)
46501 C...  Then look for real name
46502                 IBEG=9
46503  240            IBEG=IBEG+1
46504                 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
46505  250            IBEG=IBEG+1
46506                 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
46507                 IEND=IBEG-1
46508  260            IEND=IEND+1
46509                 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) 
46510      &               GOTO 260
46511                 IF (IEND.LT.59) THEN
46512                   READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
46513                   IF (CHDUM.NE.' ') CHTMP=CHDUM
46514                 ENDIF
46515  270            READ(CHTMP,'(A)') CHAF(KCQ,1)
46516                 MSTU(20)=0
46517 C...  Set stable for now
46518                 PMAS(KCQ,2)=1D-6
46519                 MWID(KCQ)=0
46520                 MDCY(KCQ,1)=0
46521                 MDCY(KCQ,2)=0
46522                 MDCY(KCQ,3)=0
46523               ENDIF
46524             ELSE
46525               WRITE(MSTU(11),'(A,I9,A)')
46526      &             ' * (PYSLHA:) Warning! Failed to read  '
46527      &             //CHBLCK(1:8)//'    for KF =',KFQ,
46528      &             ' (entry reserved by PYTHIA)'
46529               MERR=7
46530             ENDIF
46531           ENDIF
46532 C...  Finalize this line and read next.
46533           GOTO 380
46534 C...Check for DECAY begin statement (decays).
46535         ELSEIF (CHINL(1:3).EQ.'DEC') THEN
46536           MERR=0
46537           BRSUM=0D0
46538           CHBLCK='DECAY'
46539 C...Read KF code and WIDTH
46540           MPSIGN=1
46541           READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
46542           IF (KF.LE.0) THEN
46543             KF=-KF
46544             MPSIGN=-1
46545           ENDIF
46546 C...If this is not the KF we're looking for...
46547           IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
46548 C...Set block skip flag and read next line.
46549             MERR=16
46550             GOTO 380
46551           ELSE
46552 C...Check whether decay table for this particle already read in
46553             DO 280 IDECAY=1,NDECAY
46554               IF (KFDEC(IDECAY).EQ.KF) THEN
46555                 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
46556      &               ' * (PYSLHA:) Ignoring DECAY table ',
46557      &               'for KF =',KF,' on line ',CHNLIN,
46558      &               ' (duplicate)'
46559                 MERR=16
46560                 GOTO 380
46561               ENDIF
46562   280       CONTINUE
46563           ENDIF
46564  
46565 C...Determine PYTHIA KC code of particle
46566           KCREP=0
46567           IF(KF.LE.100) THEN
46568             KCREP=KF
46569           ELSE
46570             DO 290 KCR=101,KCC
46571               IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
46572   290       CONTINUE
46573           ENDIF
46574           KC=KCREP
46575           IF (KCREP.NE.0) THEN
46576 C...Particle is already known. Do not overwrite low-mass SM particles, 
46577 C...since this could give problems at hadronization / hadron decay stage.
46578             IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
46579 C...Set block skip flag and read next line
46580               WRITE(MSTU(11),'(A,I9,A,F12.3)')
46581      &             ' * (PYSLHA:) Ignoring DECAY table for KF =',
46582      &             KF, ' (SLHA read-in not allowed)'
46583               MERR=16
46584               GOTO 380
46585             ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24) 
46586      &        THEN
46587 C...Set block skip flag and read next line
46588               WRITE(MSTU(11),'(A,I9,A,F12.3)')
46589      &             ' * (PYSLHA:) Allowing DECAY table for KF =',
46590      &             KF, ' but this is NOT recommended.'
46591             ENDIF
46592           ELSE
46593 C...  Add new particle. Actually, this should not happen.
46594 C...  New particles should be added already when reading the spectrum
46595 C...  information, so go under previously stable category.
46596             KCC=KCC+1
46597             KC=KCC
46598           ENDIF
46599  
46600           IF (WIDTH.LE.0D0) THEN
46601 C...Stable (i.e. LSP)
46602             WRITE(MSTU(11),'(A,I9,A,A)')
46603      &           ' * (PYSLHA:) Reading  SLHA stable particle KF =',
46604      &              KF,', ',CHAF(KCREP,1)(1:16)
46605             IF (WIDTH.LT.0D0) THEN
46606               CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
46607      &             ' zero !')
46608               WIDTH=0D0
46609             ENDIF
46610             PMAS(KC,2)=1D-6
46611             MWID(KC)=0
46612             MDCY(KC,1)=0
46613 C...Ignore any decay lines that may be present for this KF
46614             MERR=16
46615             MDCY(KC,2)=0
46616             MDCY(KC,3)=0
46617 C...Return ok
46618             IRETRN=0
46619           ENDIF
46620 C...Finalize and start reading in decay modes.
46621           GOTO 380
46622         ELSEIF (MOD(MERR,10).GE.6) THEN
46623 C...If ignore block flag set, skip directly to next line.
46624           GOTO 170
46625         ENDIF
46626  
46627 C...READ SPECTRUM
46628         IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
46629           IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46630      &        THEN
46631             READ(CHINL,*) INDX, IVAL
46632             IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
46633             IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
46634             IF (INDX.EQ.3) KCHG(KCQ,2)=0
46635             IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
46636             IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
46637             IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
46638             IF (INDX.EQ.4) THEN
46639               KCHG(KCQ,3)=IVAL
46640               IF (IVAL.EQ.1) THEN
46641                 CHTMP=CHAF(KCQ,1)
46642                 IF (CHTMP.EQ.' ') THEN
46643                   WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
46644                   WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
46645                 ELSE
46646                   ILAST=17
46647   300             ILAST=ILAST-1
46648                   IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
46649                   IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
46650                     CHTMP(ILAST:ILAST)='-'
46651                   ELSE
46652                     CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
46653                   ENDIF
46654                   CHAF(KCQ,2)=CHTMP
46655                 ENDIF
46656               ENDIF
46657             ENDIF
46658           ELSE
46659             MERR=8
46660           ENDIF
46661         ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
46662 C...MASS: Mass spectrum
46663           IF (CHBLCK(1:4).EQ.'MASS') THEN
46664             READ(CHINL,*) KF, VAL
46665             MERR=1
46666             KC=0
46667             IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
46668 C...Read in masses for almost anything
46669               MERR=0
46670               KC=PYCOMP(KF)
46671               IF (KC.NE.0) THEN
46672 C...Don't read in masses for special code particles
46673                 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
46674                   WRITE(MSTU(11),'(A,I9,A,F12.3)')
46675      &                 ' * (PYSLHA:) Ignoring MASS  entry for KF =',
46676      &                 KF, ' (KF reserved by PYTHIA)' 
46677                   GOTO 170
46678                 ENDIF
46679 C...Be careful with light SM particles / hadrons
46680                 IF (PMAS(KC,1).LE.20D0) THEN
46681                   IF (IABS(KF).LE.22) THEN
46682                     WRITE(MSTU(11),'(A,I9,A,F12.3)')
46683      &                   ' * (PYSLHA:) Ignoring MASS  entry for KF =',
46684      &                   KF, ' (SLHA read-in not allowed)'
46685 
46686                     GOTO 170
46687                   ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
46688                     WRITE(MSTU(11),'(A,I9,A,F12.3)')
46689      &                   ' * (PYSLHA:) Ignoring MASS  entry for KF =',
46690      &                   KF, ' (SLHA read-in not allowed)'
46691                     GOTO 170
46692                   ENDIF
46693                 ENDIF
46694                 MSPC(1)=MSPC(1)+1
46695                 PMAS(KC,1) = ABS(VAL)
46696                 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
46697                   WRITE(MSTU(11),'(A,I9,A,F12.3)')
46698      &                 ' * (PYSLHA:) Reading  MASS  entry for KF =',
46699      &                 KF, ', pole mass =', VAL
46700                   IRETRN=0
46701                 ENDIF
46702 C...Check Z, W and top masses
46703                 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
46704      &               THEN
46705                   WRITE(CHTMP,8500) PMAS(PYCOMP(23),1)
46706                   CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
46707      &                 //CHTMP)
46708                 ENDIF
46709                 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
46710      &               THEN
46711                   WRITE(CHTMP,8500) PMAS(PYCOMP(24),1)
46712                   CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
46713      &                 //CHTMP)
46714                 ENDIF
46715                 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
46716      &               THEN
46717                   WRITE(CHTMP,8500) PMAS(PYCOMP(6),1)
46718                   CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
46719      &                 //CHTMP//'GeV')
46720                 ENDIF
46721 C...  Signed masses
46722                 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
46723                 IF (KF.EQ.1000022) SMZ(1)=VAL
46724                 IF (KF.EQ.1000023) SMZ(2)=VAL
46725                 IF (KF.EQ.1000025) SMZ(3)=VAL
46726                 IF (KF.EQ.1000035) SMZ(4)=VAL
46727                 IF (KF.EQ.1000024) SMW(1)=VAL
46728                 IF (KF.EQ.1000037) SMW(2)=VAL
46729 C...  Also store gravitino mass in RMSS(21), translated to eV unit
46730                 IF (KF.EQ.1000039) RMSS(21) = 1D9 * VAL
46731               ENDIF
46732             ELSEIF (MUPDA.EQ.5) THEN
46733               MERR=0
46734             ENDIF
46735 C...  MODSEL: Model selection and global switches
46736           ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
46737             READ(CHINL,*) INDX, IVAL
46738             IF (INDX.LE.200.AND.INDX.GT.0) THEN
46739               IF (IMSS(1).EQ.0) IMSS(1)=11
46740               MODSEL(INDX)=IVAL
46741               MMOD(1)=MMOD(1)+1
46742               IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
46743 C...  Switch on NMSSM
46744                 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
46745                 IMSS(13)=MAX(1,IMSS(13))
46746 C...  Add NMSSM states if not already done
46747  
46748                 KFN=25
46749                 KCN=KFN
46750                 CHAF(KCN,1)='h_10'
46751                 CHAF(KCN,2)=' '
46752  
46753                 KFN=35
46754                 KCN=KFN
46755                 CHAF(KCN,1)='h_20'
46756                 CHAF(KCN,2)=' '
46757  
46758                 KFN=45
46759                 KCN=KFN
46760                 CHAF(KCN,1)='h_30'
46761                 CHAF(KCN,2)=' '
46762  
46763                 KFN=36
46764                 KCN=KFN
46765                 CHAF(KCN,1)='A_10'
46766                 CHAF(KCN,2)=' '
46767  
46768                 KFN=46
46769                 KCN=KFN
46770                 CHAF(KCN,1)='A_20'
46771                 CHAF(KCN,2)=' '
46772  
46773                 KFN=1000045
46774                 KCN=PYCOMP(KFN)
46775                 IF (KCN.EQ.0) THEN
46776                   DO 310 KCT=100,MSTU(6)
46777                     IF(KCHG(KCT,4).GT.100) KCN=KCT
46778   310             CONTINUE
46779                   KCN=KCN+1
46780                   KCHG(KCN,4)=KFN
46781                   MSTU(20)=0
46782                 ENDIF
46783 C...  Set stable for now
46784                 PMAS(KCN,2)=1D-6
46785                 MWID(KCN)=0
46786                 MDCY(KCN,1)=0
46787                 MDCY(KCN,2)=0
46788                 MDCY(KCN,3)=0
46789                 CHAF(KCN,1)='~chi_50'
46790                 CHAF(KCN,2)=' '
46791               ENDIF
46792             ELSE
46793               MERR=1
46794             ENDIF
46795           ELSEIF (MUPDA.EQ.5) THEN
46796 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46797             MERR=8
46798           ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46799      &          CHBLCK(1:8).EQ.'PARTICLE') THEN
46800 C...Don't print a warning for QNUMBERS when reading spectrum
46801             MERR=8
46802 C...MINPAR: Minimal model parameters
46803           ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46804             READ(CHINL,*) INDX, VAL
46805             IF (INDX.LE.100.AND.INDX.GT.0) THEN
46806               PARMIN(INDX)=VAL
46807               MMOD(2)=MMOD(2)+1
46808             ELSE
46809               MERR=1
46810             ENDIF
46811             IF (MMOD(3).NE.0) THEN
46812               WRITE(MSTU(11),*)
46813      &             '* (PYSLHA:) MINPAR should come before EXTPAR !'
46814               MERR=1
46815             ENDIF
46816 C...tan(beta)
46817             IF (INDX.EQ.3) RMSS(5)=VAL
46818 C...EXTPAR: non-minimal model parameters.
46819           ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46820             IF (MMOD(1).NE.0) THEN
46821               READ(CHINL,*) INDX, VAL
46822               IF (INDX.LE.200.AND.INDX.GT.0) THEN
46823                 PAREXT(INDX)=VAL
46824                 MMOD(3)=MMOD(3)+1
46825               ELSE
46826                 MERR=1
46827               ENDIF
46828             ELSE
46829               WRITE(MSTU(11),*)
46830      &             '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46831               MERR=1
46832             ENDIF
46833 C...tan(beta)
46834             IF (INDX.EQ.25) RMSS(5)=VAL
46835           ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46836             READ(CHINL,*) INDX, VAL
46837             IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46838               MERR=1
46839             ELSEIF (INDX.EQ.4) THEN
46840               PMAS(PYCOMP(23),1)=VAL
46841             ELSEIF (INDX.EQ.6) THEN
46842               PMAS(PYCOMP(6),1)=VAL
46843             ENDIF
46844           ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46845      $           .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46846      $           .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46847      $           THEN
46848 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46849             IM=0
46850             IF (CHBLCK(5:6).EQ.'IM') IM=1
46851   320       READ(CHINL,*) INDX1, INDX2, VAL
46852             IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46853               IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46854               IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46855               MSPC(2)=MSPC(2)+1
46856             ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46857               IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46858               IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46859               MSPC(3)=MSPC(3)+1
46860             ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46861               IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46862               IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46863               MSPC(4)=MSPC(4)+1
46864             ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46865      $             .CHBLCK(1:4).EQ.'STAU') THEN
46866               IF (CHBLCK(1:4).EQ.'STOP') THEN
46867                 KFSM=6
46868                 ISPC=6
46869               ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46870                 KFSM=5
46871                 ISPC=5
46872               ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46873                 KFSM=15
46874                 ISPC=7
46875               ENDIF
46876 C...Set SFMIX element
46877               SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46878               MSPC(ISPC)=MSPC(ISPC)+1
46879             ENDIF
46880 C...Running parameters
46881           ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46882             READ(CHBLCK(8:25),*,ERR=620) Q
46883             READ(CHINL,*) INDX, VAL
46884             MSPC(8)=MSPC(8)+1
46885             IF (INDX.EQ.1) THEN
46886               RMSS(4) = VAL
46887             ELSE
46888               MERR=1
46889               MSPC(8)=MSPC(8)-1
46890             ENDIF
46891           ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46892             READ(CHINL,*,ERR=630) VAL
46893             RMSS(18)= VAL
46894             MSPC(17)=MSPC(17)+1
46895 C...Higgs parameters set manually or with FeynHiggs.
46896             IMSS(4)=MAX(2,IMSS(4))
46897           ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46898      &           .CHBLCK(1:2).EQ.'AE') THEN
46899             READ(CHBLCK(9:26),*,ERR=620) Q
46900             READ(CHINL,*) INDX1, INDX2, VAL
46901             IF (CHBLCK(2:2).EQ.'U') THEN
46902               AU(INDX1,INDX2)=VAL
46903               IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46904               MSPC(11)=MSPC(11)+1
46905             ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46906               AD(INDX1,INDX2)=VAL
46907               IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46908               MSPC(10)=MSPC(10)+1
46909             ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46910               AE(INDX1,INDX2)=VAL
46911               IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46912               MSPC(12)=MSPC(12)+1
46913             ELSE
46914               MERR=1
46915             ENDIF
46916           ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46917             IF (MSPC(18).EQ.0) THEN
46918               READ(CHBLCK(9:25),*,ERR=620) Q
46919               RMSOFT(0)=Q
46920             ENDIF
46921             READ(CHINL,*) INDX, VAL
46922             RMSOFT(INDX)=VAL
46923             MSPC(18)=MSPC(18)+1
46924           ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46925             MERR=8
46926           ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46927      &           .CHBLCK(1:2).EQ.'YE') THEN
46928             MERR=8
46929           ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46930             READ(CHINL(1:6),*) INDX
46931             IT=0
46932             MIRD=0
46933   330       IT=IT+1
46934             IF (CHINL(IT:IT).EQ.' ') GOTO 330
46935 C...Don't read index
46936             IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46937               MIRD=1
46938               GOTO 330
46939             ENDIF
46940             IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46941             IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46942           ELSE
46943 C...  Set unrecognized block flag.
46944             MERR=6
46945           ENDIF
46946  
46947 C...DECAY TABLES
46948 C...Read in decay information
46949         ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46950 C...Read new decay chanel
46951           IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46952             NDC=NDC+1
46953 C...Read in branching ratio and number of daughters for this mode.
46954             READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46955             READ(CHINL(4:50),*,ERR=600) DUM, NDA
46956             IF (NDA.LE.5) THEN
46957               IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46958      &             '(PYSLHA:) Decay data arrays full by KF = '
46959      $             //CHAF(KC,1))
46960 C...If first decay channel, set decays start point in decay table
46961               IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46962                 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46963      &               '* (PYSLHA:) Reading  DECAY table for '//
46964      &               'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46965 C...Set particle parameters (mass set when reading BLOCK MASS above)
46966                 PMAS(KC,2)=WIDTH
46967                 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46968                   WRITE(MSTU(11),'(1x,A)')
46969      &                '*  Note: the Pythia gg->h/H/A cross section'//
46970      &                ' is proportional to the h/H/A->gg width'
46971                 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46972      &                 .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46973                   WRITE(MSTU(11),'(1x,A,A16)')
46974      &                 '* Warning: will use DECAY table (fixed-width,'//
46975      &                 ' flat PS) for ',CHAF(KC,1)(1:16)
46976                 ENDIF
46977                 PMAS(KC,3)=0D0
46978                 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46979                 MWID(KC)=2
46980                 MDCY(KC,1)=1
46981                 MDCY(KC,2)=NDC
46982                 MDCY(KC,3)=0
46983 C...Add to list of DECAY blocks currently read
46984                 NDECAY=NDECAY+1
46985                 KFDEC(NDECAY)=KF
46986 C...Return ok
46987                 IRETRN=0
46988               ENDIF
46989 C...  Count up number of decay modes for this particle
46990               MDCY(KC,3)=MDCY(KC,3)+1
46991 C...  Read in decay daughters.
46992               READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46993 C...  Flip sign if reading antiparticle decays (if antipartner exists)
46994               DO 340 IDA=1,NDA
46995                 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46996      &               IDC(IDA)=MPSIGN*IDC(IDA)
46997   340         CONTINUE
46998 C...Switch on decay channel
46999 C             MDME(NDC,1)=1
47000               IF(MDME(NDC,1).LT.0.AND.MDME(NDC,1).GE.-5) THEN
47001                 MDME(NDC,1)=-MDME(NDC,1)
47002               ELSE
47003                 MDME(NDC,1)=1
47004               ENDIF
47005 
47006 C...Switch off decay channels with < 0 branching fraction
47007               IF (BRAT(NDC).LE.0D0) THEN
47008                 MDME(NDC,1)=0
47009 C...Else check if decays to gravitinos should be switched on
47010               ELSE 
47011                 DO 345 IDA=1,NDA
47012                   IF (IDC(IDA).EQ.1000039) THEN
47013 C...  Inform user 
47014                     IF (IMSS(11).LE.0) WRITE(MSTU(11),*)
47015      &                   '* (PYSLHA:) Switching on decays to gravitinos'
47016                     IMSS(11) = 2
47017                   ENDIF
47018  345            CONTINUE                
47019               ENDIF
47020 
47021 C...Store decay products ordered in decreasing ABS(KF)
47022               BRSUM=BRSUM+ABS(BRAT(NDC))
47023               BRAT(NDC)=ABS(BRAT(NDC))
47024   350         IFLIP=0
47025               DO 360 IDA=1,NDA-1
47026                 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
47027                   ITMP=IDC(IDA)
47028                   IDC(IDA)=IDC(IDA+1)
47029                   IDC(IDA+1)=ITMP
47030                   IFLIP=IFLIP+1
47031                 ENDIF
47032   360         CONTINUE
47033               IF (IFLIP.GT.0) GOTO 350
47034 C...Treat as ordinary decay, no fancy stuff.
47035               MDME(NDC,2)=0
47036               DO 370 IDA=1,5
47037                 IF (IDA.LE.NDA) THEN
47038                   KFDP(NDC,IDA)=IDC(IDA)
47039                 ELSE
47040                   KFDP(NDC,IDA)=0
47041                 ENDIF
47042   370         CONTINUE
47043 C              WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
47044 C     &            (KFDP(NDC,J),J=1,NDA)
47045             ELSE
47046               CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
47047      &             CHNLIN)
47048               MERR=11
47049               NDC=NDC-1
47050             ENDIF
47051           ELSEIF(CHINL(1:1).EQ.'+') THEN
47052             MERR=11
47053           ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
47054             MERR=16
47055           ELSE
47056             MERR=16
47057           ENDIF
47058         ENDIF
47059 C...  Error check.
47060   380   IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
47061           WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
47062      &         //CHINL(1:40)
47063           MERR=0
47064         ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
47065           WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
47066      &         CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
47067         ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
47068           WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
47069      &         //CHBLCK(1:INL)//'... on line'//CHNLIN
47070         ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
47071      &         CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
47072           WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
47073      &         //'... on line'//CHNLIN
47074         ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
47075           WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
47076      &         /CHBLCK(1:INL)//'... on line'//CHNLIN
47077         ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
47078           WRITE (CHTMP,*) KF
47079           WRITE(MSTU(11),*)
47080      &         '* (PYSLHA:) Ignoring extra MASS entry for KF='//
47081      &         CHTMP(1:9)//' on line'//CHNLIN
47082         ENDIF
47083 C...Iterate read loop
47084         GOTO 170
47085 C...Error catching
47086   390   WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
47087      &      ', ignoring subsequent lines.'
47088         WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
47089         CHBLCK=' '
47090         GOTO 170
47091 C...End of read loop
47092   400   CONTINUE
47093 C...Set flag that KC codes have been rearranged.
47094         MSTU(20)=0
47095         VERBOS=0
47096  
47097 C...Perform possible tests that new information is consistent.
47098         IF (MUPDA.EQ.1) THEN
47099           MSTU23=MSTU(23)
47100           MSTU27=MSTU(27)
47101 C...Check masses
47102           DO 410 ISUSY=1,37
47103             KF=KFSUSY(ISUSY)
47104 C...Don't complain about right-handed neutrinos
47105             IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
47106      &           +16) GOTO 410
47107 C...Only check gravitino in GMSB scenarios
47108             IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
47109             KC=PYCOMP(KF)
47110             IF (PMAS(KC,1).EQ.0D0) THEN
47111               WRITE(CHTMP,*) KF
47112               CALL PYERRM(9
47113      &             ,'(PYSLHA:) No mass information found for KF ='
47114      &             //CHTMP)
47115             ENDIF
47116   410     CONTINUE
47117 C...Check mixing matrices (MSSM only)
47118           IF (IMSS(13).EQ.0) THEN
47119             IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
47120      &           ,'(PYSLHA:) Inconsistent # of elements in NMIX')
47121             IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
47122      &           ,'(PYSLHA:) Inconsistent # of elements in UMIX')
47123             IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
47124      &           ,'(PYSLHA:) Inconsistent # of elements in VMIX')
47125             IF (MSPC(5).NE.4) CALL PYERRM(9
47126      &           ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
47127             IF (MSPC(6).NE.4) CALL PYERRM(9
47128      &           ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
47129             IF (MSPC(7).NE.4) CALL PYERRM(9
47130      &           ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
47131             IF (MSPC(8).LT.1) CALL PYERRM(9
47132      &           ,'(PYSLHA:) Too few elements in HMIX')
47133             IF (MSPC(10).EQ.0) CALL PYERRM(9
47134      &           ,'(PYSLHA:) Missing A_b trilinear coupling')
47135             IF (MSPC(11).EQ.0) CALL PYERRM(9
47136      &           ,'(PYSLHA:) Missing A_t trilinear coupling')
47137             IF (MSPC(12).EQ.0) CALL PYERRM(9
47138      &           ,'(PYSLHA:) Missing A_tau trilinear coupling')
47139             IF (MSPC(17).LT.1) CALL PYERRM(9
47140      &           ,'(PYSLHA:) Missing Higgs mixing angle alpha')
47141           ENDIF
47142 C...Check wavefunction normalizations.
47143 C...Sfermions
47144           DO 420 ISPC=5,7
47145             IF (MSPC(ISPC).EQ.4) THEN
47146               KFSM=ISPC
47147               IF (ISPC.EQ.7) KFSM=15
47148               CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
47149      &             *SFMIX(KFSM,3))
47150               IF (ABS(1D0-CHECK).GT.1D-3) THEN
47151                 KCSM=PYCOMP(KFSM)
47152                 CALL PYERRM(17
47153      &               ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
47154      &               //CHAF(KCSM,1))
47155               ENDIF
47156 C...Bug fix 30/09 2008: PS
47157 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
47158               IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
47159                 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
47160                 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
47161               ENDIF
47162             ENDIF
47163   420     CONTINUE
47164 C...Neutralinos + charginos
47165           DO 440 J=1,4
47166             CN1=0D0
47167             CN2=0D0
47168             CU1=0D0
47169             CU2=0D0
47170             CV1=0D0
47171             CV2=0D0
47172             DO 430 L=1,4
47173               CN1=CN1+ZMIX(J,L)**2
47174               CN2=CN2+ZMIX(L,J)**2
47175               IF (J.LE.2.AND.L.LE.2) THEN
47176                 CU1=CU1+UMIX(J,L)**2
47177                 CU2=CU2+UMIX(L,J)**2
47178                 CV1=CV1+VMIX(J,L)**2
47179                 CV2=CV2+VMIX(L,J)**2
47180               ENDIF
47181   430       CONTINUE
47182 C...NMIX normalization
47183             IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
47184      &           .GT.1D-3).AND.IMSS(13).EQ.0) THEN
47185               CALL PYERRM(19,
47186      &             '(PYSLHA:) NMIX: Inconsistent normalization.')
47187               WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
47188             ENDIF
47189 C...UMIX, VMIX normalizations
47190             IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
47191               IF (J.LE.2) THEN
47192                 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
47193                   CALL PYERRM(19
47194      &                ,'(PYSLHA:) UMIX: Inconsistent normalization.')
47195                   WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
47196      &                 CU2
47197                 ENDIF
47198                 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
47199                   CALL PYERRM(19,
47200      &                '(PYSLHA:) VMIX: Inconsistent normalization.')
47201                   WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
47202      &                 CV2
47203                 ENDIF
47204               ENDIF
47205             ENDIF
47206   440     CONTINUE
47207           IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
47208             WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
47209      &           '* (PYSLHA:) No spectrum inconsistencies were found.'
47210           ELSE
47211             WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
47212      &           '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
47213      &           ,' Warning: one or more (serious)'//
47214      &           ' inconsistencies were found in the spectrum !'
47215      &           ,' Read the error messages above and check your'//
47216      &           ' input file.'
47217           ENDIF
47218 C...Increase precision in Higgs sector using FeynHiggs
47219           IF (IMSS(4).EQ.3) THEN
47220 C...FeynHiggs needs MSOFT.
47221             IERR=0
47222             IF (MSPC(18).EQ.0) THEN
47223               WRITE(MSTU(11),'(1x,"*"/1x,A/)')
47224      &             '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
47225      &              ' Cannot call FeynHiggs.'
47226               IERR=-1
47227             ELSE
47228               WRITE(MSTU(11),'(1x,/1x,A/)')
47229      &             '* (PYSLHA:) Now calling FeynHiggs.'
47230               CALL PYFEYN(IERR)
47231               IF (IERR.NE.0) IMSS(4)=2
47232             ENDIF
47233           ENDIF
47234         ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
47235           IBEG=1
47236           IF (KFORIG.NE.0) IBEG=NDECAY
47237           DO 490 IDECAY=IBEG,NDECAY
47238             KF = KFDEC(IDECAY)
47239             KC = PYCOMP(KF)
47240             WRITE(CHKF,8300) KF
47241             IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
47242      $          ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
47243      $          .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
47244      $          ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
47245      $          //CHKF)
47246             BRSUM=0D0
47247             BROPN=0D0
47248             DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47249               IF(MDME(IDA,2).GT.80) GOTO 460
47250               KQ=KCHG(KC,1)
47251               PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47252               MERR=0
47253               DO 450 J=1,5
47254                 KP=KFDP(IDA,J)
47255                 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47256                   IF(KP.EQ.81) KQ=0
47257                 ELSEIF(PYCOMP(KP).EQ.0) THEN
47258                   MERR=3
47259                 ELSE
47260                   KQ=KQ-PYCHGE(KP)
47261                   KPC=PYCOMP(KP)
47262                   PMS=PMS-PMAS(KPC,1)
47263                   IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47264      &                PMAS(KPC,3))
47265                 ENDIF
47266   450         CONTINUE
47267               IF(KQ.NE.0) MERR=MAX(2,MERR)
47268               IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47269      &            MERR=MAX(1,MERR)
47270               IF(MERR.EQ.3) CALL PYERRM(17,
47271      &            '(PYSLHA:) Unknown particle code in decay of KF ='
47272      $            //CHKF)
47273               IF(MERR.EQ.2) CALL PYERRM(17,
47274      &            '(PYSLHA:) Charge not conserved in decay of KF ='
47275      $            //CHKF)
47276               IF(MERR.EQ.1) CALL PYERRM(7,
47277      &            '(PYSLHA:) Kinematically unallowed decay of KF ='
47278      $            //CHKF)
47279               BRSUM=BRSUM+BRAT(IDA)
47280               IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
47281   460       CONTINUE
47282 C...Check branching ratio sum.
47283             IF (BROPN.LE.0D0) THEN
47284 C...If zero, set stable.
47285               WRITE(CHTMP,8500) BROPN
47286               CALL PYERRM(7
47287      &            ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
47288      &            CHTMP(9:16)//'. Changed to stable.')
47289               PMAS(KC,2)=1D-6
47290               MWID(KC)=0
47291 C...If BR's > 1, rescale.
47292             ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
47293               WRITE(CHTMP,8500) BRSUM
47294               IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
47295      &            ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
47296      &            ' ; sum was '//CHTMP(9:16)//'.')
47297               FAC=1D0/BRSUM
47298               DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47299                 IF(MDME(IDA,2).GT.80) GOTO 470
47300                 BRAT(IDA)=FAC*BRAT(IDA)
47301   470         CONTINUE
47302             ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
47303 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
47304               WRITE(CHTMP,8500) BRSUM
47305               IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
47306      &            ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
47307      &            CHTMP(9:16)//'. Dummy mode will be inserted.')
47308 C...Move table and insert dummy mode
47309               DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47310                 NDC=NDC+1
47311                 BRAT(NDC)=BRAT(IDA)
47312                 KFDP(NDC,1)=KFDP(IDA,1)
47313                 KFDP(NDC,2)=KFDP(IDA,2)
47314                 KFDP(NDC,3)=KFDP(IDA,3)
47315                 KFDP(NDC,4)=KFDP(IDA,4)
47316                 KFDP(NDC,5)=KFDP(IDA,5)
47317                 MDME(NDC,1)=MDME(IDA,1)
47318   480         CONTINUE
47319               NDC=NDC+1
47320               BRAT(NDC)=1D0-BRSUM
47321               KFDP(NDC,1)=0
47322               KFDP(NDC,2)=0
47323               KFDP(NDC,3)=0
47324               KFDP(NDC,4)=0
47325               KFDP(NDC,5)=0
47326               MDME(NDC,1)=0
47327               BRSUM=1D0
47328 C...Update MDCY
47329               MDCY(KC,3)=MDCY(KC,3)+1
47330               MDCY(KC,2)=NDC-MDCY(KC,3)+1
47331             ENDIF
47332   490     CONTINUE
47333         ENDIF
47334  
47335  
47336 C...WRITE SPECTRUM ON SLHA FILE
47337       ELSEIF(MUPDA.EQ.3) THEN
47338 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
47339         IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
47340           MODSEL(1)=1
47341           PARMIN(1)=RMSS(8)
47342           PARMIN(2)=RMSS(1)
47343           PARMIN(3)=RMSS(5)
47344           PARMIN(4)=SIGN(1D0,RMSS(4))
47345           PARMIN(5)=RMSS(36)
47346         ENDIF
47347 C...Write spectrum
47348         WRITE(LFN,7000) 'SLHA MSSM spectrum'
47349         WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
47350      &    // ' P. Skands.'
47351         WRITE(LFN,7010) 'MODSEL',  'Model selection'
47352         WRITE(LFN,7110) 1, MODSEL(1)
47353         WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
47354         IF (MODSEL(1).EQ.1) THEN
47355           WRITE(LFN,7210) 1, PARMIN(1), 'm0'
47356           WRITE(LFN,7210) 2, PARMIN(2), 'm12'
47357           WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47358           WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47359           WRITE(LFN,7210) 5, PARMIN(5), 'a0'
47360         ELSEIF(MODSEL(2).EQ.2) THEN
47361           WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
47362           WRITE(LFN,7210) 2, PARMIN(2), 'M'
47363           WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47364           WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47365           WRITE(LFN,7210) 5, PARMIN(5), 'N5'
47366           WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
47367         ENDIF
47368         WRITE(LFN,7000) ' '
47369         WRITE(LFN,7010) 'MASS', 'Mass spectrum'
47370         DO 500 I=1,36
47371           KF=KFSUSY(I)
47372           KC=PYCOMP(KF)
47373           IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
47374           KFSM=KF-KSUSY1
47375           IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
47376             IF (KFSM.EQ.22)  WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
47377             IF (KFSM.EQ.23)  WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
47378             IF (KFSM.EQ.25)  WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
47379             IF (KFSM.EQ.35)  WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
47380             IF (KFSM.EQ.24)  WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
47381             IF (KFSM.EQ.37)  WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
47382           ELSE
47383             WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
47384           ENDIF
47385   500   CONTINUE
47386 C...SUSY scale
47387         RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
47388         WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
47389         WRITE(LFN,7210) 1, RMSS(4),'mu'
47390         WRITE(LFN,7010) 'ALPHA',' '
47391 C       WRITE(LFN,7210) 1, RMSS(18), 'alpha'
47392         WRITE(LFN,7200) RMSS(18), 'alpha'
47393         WRITE(LFN,7020) 'AU',RMSUSY
47394         WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
47395         WRITE(LFN,7020) 'AD',RMSUSY
47396         WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
47397         WRITE(LFN,7020) 'AE',RMSUSY
47398         WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
47399         WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
47400         WRITE(LFN,7410) 1, 1, SFMIX(6,1)
47401         WRITE(LFN,7410) 1, 2, SFMIX(6,2)
47402         WRITE(LFN,7410) 2, 1, SFMIX(6,3)
47403         WRITE(LFN,7410) 2, 2, SFMIX(6,4)
47404         WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
47405         WRITE(LFN,7410) 1, 1, SFMIX(5,1)
47406         WRITE(LFN,7410) 1, 2, SFMIX(5,2)
47407         WRITE(LFN,7410) 2, 1, SFMIX(5,3)
47408         WRITE(LFN,7410) 2, 2, SFMIX(5,4)
47409         WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
47410         WRITE(LFN,7410) 1, 1, SFMIX(15,1)
47411         WRITE(LFN,7410) 1, 2, SFMIX(15,2)
47412         WRITE(LFN,7410) 2, 1, SFMIX(15,3)
47413         WRITE(LFN,7410) 2, 2, SFMIX(15,4)
47414         WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
47415         DO 520 I1=1,4
47416           DO 510 I2=1,4
47417             WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
47418   510     CONTINUE
47419   520   CONTINUE
47420         WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
47421         DO 540 I1=1,2
47422           DO 530 I2=1,2
47423             WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
47424   530     CONTINUE
47425   540   CONTINUE
47426         WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
47427         DO 560 I1=1,2
47428           DO 550 I2=1,2
47429             WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
47430   550     CONTINUE
47431   560   CONTINUE
47432         WRITE(LFN,7010) 'SPINFO'
47433         IF (IMSS(1).EQ.2) THEN
47434           CPRO(1)='PYTHIA'
47435           CVER(1)='6.4'
47436         ELSEIF (IMSS(1).EQ.12) THEN
47437           ISAVER=VISAJE()
47438           CPRO(1)='ISASUSY'
47439           CVER(1)=ISAVER(1:12)
47440         ENDIF
47441         WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
47442         WRITE(LFN,7310) 2, CVER(1), 'Version number'
47443       ENDIF
47444  
47445 C...Print user information about spectrum
47446       IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
47447         IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
47448      &       WRITE(MSTU(11),5030) CPRO(1), CVER(1)
47449         IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
47450         IF (MUPDA.EQ.1) THEN
47451           WRITE(MSTU(11),5020) LFN
47452         ELSE
47453           WRITE(MSTU(11),5010) LFN
47454         ENDIF
47455  
47456         WRITE(MSTU(11),5400)
47457         WRITE(MSTU(11),5500) 'Pole masses'
47458         WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
47459      $       ,(RMFUN(KSUSY2+IP),IP=1,6)
47460         WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
47461      $       ,(RMFUN(KSUSY2+IP),IP=11,16)
47462         IF (IMSS(13).EQ.0) THEN
47463           WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
47464      $         ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
47465      $         RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
47466           WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
47467      &         CHAF(37,1), ' ', ' ',' ',' ',
47468      &         RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
47469         ELSEIF (IMSS(13).EQ.1) THEN
47470           KF1=KSUSY1+21
47471           KF2=KSUSY1+22
47472           KF3=KSUSY1+23
47473           KF4=KSUSY1+25
47474           KF5=KSUSY1+35
47475           KF6=KSUSY1+45
47476           KF7=KSUSY1+24
47477           KF8=KSUSY1+37
47478           WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
47479      &         CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
47480      &         CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
47481      &         CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
47482      &         RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
47483      &         RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
47484           WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
47485      &         CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
47486      &         RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
47487      &         RMFUN(37)
47488         ENDIF
47489         WRITE(MSTU(11),5400)
47490         WRITE(MSTU(11),5500) 'Mixing structure'
47491         WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47492         WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47493      &       ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47494         WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47495      &       ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47496      &       ),(SFMIX(15,J),J=3,4)
47497         WRITE(MSTU(11),5400)
47498         WRITE(MSTU(11),5500) 'Couplings'
47499         WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
47500         WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
47501         WRITE(MSTU(11),5400)
47502         WRITE(MSTU(11),6500)
47503  
47504 C...DECAY TABLES writeout
47505 C...Write decay information by Nils-Erik Bomark 3/29/2010
47506       ELSEIF (MUPDA.EQ.4) THEN
47507         KF = KFORIG
47508         KC = PYCOMP(KF)
47509         IF (KC.NE.0) THEN
47510           WRITE(LFN,7000) ''
47511           WRITE(LFN,7000) '         PDG            Width'
47512           WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
47513           WRITE(LFN,7000) 
47514      &   '          BR         NDA      ID1        ID2       ID3'
47515           DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47516             NDA = 0
47517             DO 570 J=1,5
47518               IF (KFDP(I,J).NE.0) NDA = NDA+1
47519  570        CONTINUE
47520             IF (NDA.EQ.2) 
47521      &         WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47522      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47523      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47524             IF (NDA.EQ.3) 
47525      &         WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47526      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47527      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47528             IF (NDA.EQ.4) 
47529      &         WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47530      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47531      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47532             IF (NDA.EQ.5) 
47533      &         WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47534      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47535      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47536  575        CONTINUE
47537         ENDIF
47538 C....End of DECAY TABLES writeout
47539 
47540       ENDIF
47541   
47542 C...Only rewind when reading
47543       IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
47544  
47545  9999 RETURN
47546  
47547 C...Serious error catching
47548   580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
47549       write(*,*) CHINL(1:80)
47550       CALL PYSTOP(106)
47551   590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
47552       WRITE(*,*) CHINL(1:72)
47553       CALL PYSTOP(106)
47554   600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
47555       WRITE(*,*) CHINL(1:80)
47556       CALL PYSTOP(106)
47557   610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
47558       WRITE(*,*) CHINL(1:80)
47559   620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
47560       CALL PYSTOP(106)
47561   630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
47562       WRITE(*,*) CHINL(1:80)
47563       CALL PYSTOP(106)
47564  
47565  8300 FORMAT(I9)
47566  8500 FORMAT(F16.5)
47567  
47568 C...Formats for user information printout.
47569  5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.15: SUSY/BSM SPECTRUM '
47570      &     ,'INTERFACE',1x,17('*')/1x,'*',1x
47571      &     ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P. Skands')
47572  5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
47573  5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
47574  5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
47575  5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
47576  5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
47577  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47578      &     3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47579  5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
47580      &     ,'----------------')
47581  5400 FORMAT(1x,'*',1x,A)
47582  5500 FORMAT(1x,'*',1x,A,':')
47583  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47584      &       1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47585  5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
47586      &     4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
47587      &     ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47588  5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
47589      &     ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
47590      &     ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47591  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47592      &     ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47593      &     ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47594  6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
47595  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47596      &     ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47597      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47598      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47599      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47600      &     ,1x,F6.3,1x),'|')
47601  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47602      &     ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47603      &     ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47604      &     ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47605      &     ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47606  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47607      &     ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47608      &     ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47609      &     1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47610      &     ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47611      &     1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47612      &     ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47613  6400 FORMAT(1x,'*',3x,'  A_b = ',F8.2,4x,'      A_t = ',F8.2,4x
47614      &     ,'A_tau = ',F8.2)
47615  6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
47616      &     ,'   mu = ',F8.2)
47617  6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
47618  
47619 C...Format to use for comments
47620  7000 FORMAT('# ',A)
47621 C...Format to use for block statements
47622  7010 FORMAT('Block',1x,A,3x,'#',1x,A)
47623  7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
47624 C...Indexed Int
47625  7110 FORMAT(1x,I4,1x,I4,3x,'#')
47626 C...Non-Indexed Double
47627  7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
47628 C...Indexed Double
47629  7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
47630 C...Long Indexed Double (PDG + double)
47631  7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
47632 C...Indexed Char(12)
47633  7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
47634 C...Single matrix
47635  7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
47636 C...Double Matrix
47637  7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
47638 C...Write Decay Table
47639  7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A)
47640  7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
47641  7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
47642      &  '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
47643  7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
47644      &  '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
47645  7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
47646      &  '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
47647  7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
47648      &  '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
47649 
47650       END
47651 
47652  
47653 C*********************************************************************
47654  
47655 C...PYAPPS
47656 C...Uses approximate analytical formulae to determine the full set of
47657 C...MSSM parameters from SUGRA input.
47658 C...See M. Drees and S.P. Martin, hep-ph/9504124
47659  
47660       SUBROUTINE PYAPPS
47661  
47662 C...Double precision and integer declarations.
47663       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47664       IMPLICIT INTEGER(I-N)
47665       INTEGER PYK,PYCHGE,PYCOMP
47666 C...Parameter statement to help give large particle numbers.
47667       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47668      &KEXCIT=4000000,KDIMEN=5000000)
47669 C...Commonblocks.
47670       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47671       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47672       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47673       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
47674 
47675       WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
47676      &' not intended for serious physics studies'
47677       IMSS(5)=0
47678       IMSS(8)=0
47679       XMT=PMAS(6,1)
47680       XMZ2=PMAS(23,1)**2
47681       XMW2=PMAS(24,1)**2
47682       TANB=RMSS(5)
47683       BETA=ATAN(TANB)
47684       XW=PARU(102)
47685       XMG=RMSS(1)
47686       XMG2=XMG*XMG
47687       XM0=RMSS(8)
47688       XM02=XM0*XM0
47689 C...Temporary sign change for AT. Others unchanged.
47690       AT=-RMSS(16)
47691       RMSS(15)=RMSS(16)
47692       RMSS(17)=RMSS(16)
47693       SINB=TANB/SQRT(TANB**2+1D0)
47694       COSB=SINB/TANB
47695  
47696       DTERM=XMZ2*COS(2D0*BETA)
47697       XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
47698       XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
47699       RMSS(6)=XMEL
47700       RMSS(7)=XMER
47701       XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
47702       XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
47703       XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
47704       XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
47705       DO 100 I=1,5,2
47706         PMAS(PYCOMP(KSUSY1+I),1)=XMDL
47707         PMAS(PYCOMP(KSUSY2+I),1)=XMDR
47708         PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
47709         PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
47710   100 CONTINUE
47711       XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
47712       IF(XARG.LT.0D0) THEN
47713         WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
47714      &  ' FROM THE SUM RULE. '
47715         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
47716         RETURN
47717       ELSE
47718         XARG=SQRT(XARG)
47719       ENDIF
47720       DO 110 I=11,15,2
47721         PMAS(PYCOMP(KSUSY1+I),1)=XMEL
47722         PMAS(PYCOMP(KSUSY2+I),1)=XMER
47723         PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
47724         PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
47725   110 CONTINUE
47726       RMT=PYMRUN(6,PMAS(6,1)**2)
47727       XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
47728      &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
47729       RMB=PYMRUN(5,PMAS(6,1)**2)
47730       XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
47731      &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
47732       XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
47733       ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
47734      &SINB)**2)
47735       RMSS(16)=-ATP
47736       XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
47737      &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
47738       XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
47739       XMU=SIGN(SQRT(XMU2),RMSS(4))
47740       RMSS(4)=XMU
47741       IF(XMA2.GT.0D0) THEN
47742         RMSS(19)=SQRT(XMA2)
47743       ELSE
47744         WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
47745         CALL PYSTOP(102)
47746       ENDIF
47747       ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
47748       IF(ARG.GT.0D0) THEN
47749         RMSS(14)=SQRT(ARG)
47750       ELSE
47751         WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
47752         CALL PYSTOP(102)
47753       ENDIF
47754       ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
47755       IF(ARG.GT.0D0) THEN
47756         RMSS(13)=SQRT(ARG)
47757       ELSE
47758         WRITE(MSTU(11),*) ' PYAPPS::  LEFT STAU MASS**2 < 0 '
47759         CALL PYSTOP(102)
47760       ENDIF
47761       ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
47762       IF(ARG.GT.0D0) THEN
47763         RMSS(10)=SQRT(ARG)
47764       ELSE
47765         RMSS(10)=-SQRT(-ARG)
47766       ENDIF
47767       ARG=PYRNMQ(2,-2D0*XTOP/3D0)
47768       IF(ARG.GT.0D0) THEN
47769         RMSS(12)=SQRT(ARG)
47770       ELSE
47771         RMSS(12)=-SQRT(-ARG)
47772       ENDIF
47773       ARG=PYRNMQ(3,-2D0*XBOT/3D0)
47774       IF(ARG.GT.0D0) THEN
47775         RMSS(11)=SQRT(ARG)
47776       ELSE
47777         RMSS(11)=-SQRT(-ARG)
47778       ENDIF
47779  
47780       RETURN
47781       END
47782  
47783 C*********************************************************************
47784  
47785 C...PYSUGI
47786 C...Interface to ISASUSY version 7.71.
47787 C...Warning: this interface should not be used with earlier versions
47788 C...of ISASUSY, since common block incompatibilities may then arise.
47789 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
47790 C...Then converts to Gunion-Haber conventions.
47791  
47792       SUBROUTINE PYSUGI
47793       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47794  
47795       INTEGER PYK,PYCHGE,PYCOMP
47796       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47797      &KEXCIT=4000000,KDIMEN=5000000)
47798  
47799 C...Date of Change
47800       CHARACTER DOC*11
47801       PARAMETER (DOC='01 May 2006')
47802  
47803 C...ISASUGRA Input:
47804       REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
47805 C...XISAIN contains the MSSMi inputs in natural order.
47806       COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
47807      $XAMIN(7)
47808       REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
47809       SAVE /SUGXIN/
47810 C...ISASUGRA Output
47811       CHARACTER*40 ISAVER,VISAJE
47812       REAL SUPER
47813       COMMON /SSPAR/ SUPER(72)
47814       COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
47815      $FBGUT,FTAGUT,FNGUT
47816       REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
47817       COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47818      $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47819      $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
47820      $VUMT,VDMT,ASMTP,ASMSS,M3Q
47821       REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47822      $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47823      $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
47824       INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
47825       INTEGER IALLOW
47826       SAVE /SUGMG/,/SSPAR/
47827 C SUPER: Filled by ISASUGRA.
47828 C SUPER(1)        = mass of ~g
47829 C SUPER(2:17)     = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
47830 C                          ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
47831 C SUPER(18:25)    = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
47832 C                          ,~tau_2
47833 C SUPER(26:28)    = mass of ~nu_e,~nu_mu,~nu_tau
47834 C SUPER(29)       = Higgsino mass = - mu
47835 C SUPER(30)       = ratio v2/v1 of vev's
47836 C SUPER(31:34)    = Signed neutralino masses
47837 C SUPER(35:50)    = Neutralino mixing matrix
47838 C SUPER(51:52)    = Signed chargino masses
47839 C SUPER(53:54)    = Chargino left, right mixing angles
47840 C SUPER(55:58)    = mass of h0, H0, A0, H+
47841 C SUPER(59)       = Higgs mixing angle alpha
47842 C SUPER(60:65)    = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47843 C SUPER(66)       = Gravitino mass
47844 C SUPER(67:69)    = Top,Bottom, and Tau masses at MSUSY (not used)
47845 C SUPER(70)       = b-Yukawa at mA scale (not used)
47846 C SUPER(71:72)    = H_u, H_d vev's at MSUSY (not used)
47847 C GSS: Filled by ISASUGRA
47848 C     GSS( 1) = g_1        GSS( 2) = g_2        GSS( 3) = g_3
47849 C     GSS( 4) = y_tau      GSS( 5) = y_b        GSS( 6) = y_t
47850 C     GSS( 7) = M_1        GSS( 8) = M_2        GSS( 9) = M_3
47851 C     GSS(10) = A_tau      GSS(11) = A_b        GSS(12) = A_t
47852 C     GSS(13) = M_h12     GSS(14) = M_h22     GSS(15) = M_er2
47853 C     GSS(16) = M_el2     GSS(17) = M_dnr2    GSS(18) = M_upr2
47854 C     GSS(19) = M_upl2    GSS(20) = M_taur2   GSS(21) = M_taul2
47855 C     GSS(22) = M_btr2    GSS(23) = M_tpr2    GSS(24) = M_tpl2
47856 C     GSS(25) = mu         GSS(26) = B          GSS(27) = Y_N
47857 C     GSS(28) = M_nr       GSS(29) = A_n        GSS(30) = log(vdq)
47858 C     GSS(31) = log(vuq)
47859 C MSS: Filled by ISASUGRA
47860 C     MSS( 1) = glss     MSS( 2) = upl      MSS( 3) = upr
47861 C     MSS( 4) = dnl      MSS( 5) = dnr      MSS( 6) = stl
47862 C     MSS( 7) = str      MSS( 8) = chl      MSS( 9) = chr
47863 C     MSS(10) = b1       MSS(11) = b2       MSS(12) = t1
47864 C     MSS(13) = t2       MSS(14) = nuel     MSS(15) = numl
47865 C     MSS(16) = nutl     MSS(17) = el-      MSS(18) = er-
47866 C     MSS(19) = mul-     MSS(20) = mur-     MSS(21) = tau1
47867 C     MSS(22) = tau2     MSS(23) = z1ss     MSS(24) = z2ss
47868 C     MSS(25) = z3ss     MSS(26) = z4ss     MSS(27) = w1ss
47869 C     MSS(28) = w2ss     MSS(29) = hl0      MSS(30) = hh0
47870 C     MSS(31) = ha0      MSS(32) = h+
47871 C Unification, filled by ISASUGRA if applicable.
47872 C     MGUTSS  = M_GUT    GGUTSS  = g_GUT    AGUTSS  = alpha_GUTC
47873  
47874 C...SPYTHIA Input/Output
47875       INTEGER IMSS
47876       DOUBLE PRECISION RMSS
47877       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47878       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47879      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47880 C...SLHA Input/Output
47881       COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47882      &     AU(3,3),AD(3,3),AE(3,3)
47883 C...PYTHIA common blocks
47884       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47885       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47886       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47887  
47888       SAVE  /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47889 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47890       INTEGER IMODEL
47891       REAL M0,MHF,A0,MT
47892       CHARACTER*20 CHMOD(5)
47893       CHARACTER*32 FNAME
47894  
47895       COMMON /SUGNU/ XNUSUG(18)
47896       REAL XNUSUG
47897       SAVE /SUGNU/
47898  
47899       DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47900      &     'truly unified SUGRA', 'non-minimal GMSB'/
47901  
47902 C...Start by checking for incompatibilities/inconsistencies:
47903       DO 100 ICHK=2,9
47904         IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47905           WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47906      &         ,' option not used by PYSUGI'
47907         ENDIF
47908   100 CONTINUE
47909 C...ISAJET works with REAL numbers.
47910       MZERO=REAL(RMSS(8))
47911       MHLF=REAL(RMSS(1))
47912       AZERO=REAL(RMSS(16))
47913       TANB=REAL(RMSS(5))
47914       SGNMU=REAL(RMSS(4))
47915       MTOP=REAL(PMAS(6,1))
47916       IMODEL=0
47917       IF (IMSS(1).EQ.12) THEN
47918         IMODEL=1
47919         GOTO 130
47920       ELSEIF(IMSS(1).EQ.13) THEN
47921 C...Read from isajet par file in IMSS(20)
47922         LFN=IMSS(20)
47923 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47924         IF (LFN.EQ.0) THEN
47925           WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47926           GOTO 9999
47927         ENDIF
47928         WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47929 CMrenna change to allow any susy model
47930         WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47931         WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47932         WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47933         WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47934      &       ' gauge couplings:'
47935         WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47936         READ(LFN,*) IMODEL
47937         IF (IMODEL.EQ.4) THEN
47938           IAL3UN=1
47939           IMODEL=1
47940         ENDIF
47941         IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47942           WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47943      &         //' sgn(mu), M_t:'
47944           READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47945           IF (IMODEL.EQ.3) THEN
47946             IMODEL=1
47947  110        WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47948      &           //' 0 to continue:'
47949             WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47950             WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47951             WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47952             WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47953      &           //' generation masses'
47954             WRITE(MSTU(11),*)
47955      &           ' NUSUG5 = GUT scale 3rd generation masses'
47956             READ(LFN,*) INUSUG
47957             IF (INUSUG.EQ.0) THEN
47958               GOTO 120
47959             ELSEIF (INUSUG.EQ.1) THEN
47960               WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47961               READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47962               IF (XNUSUG(3).LE.0.) THEN
47963                 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47964                 CALL PYSTOP(109)
47965               END IF
47966             ELSEIF (INUSUG.EQ.2) THEN
47967               WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47968               READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47969             ELSEIF (INUSUG.EQ.3) THEN
47970               WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47971               READ(LFN,*) XNUSUG(7),XNUSUG(8)
47972             ELSEIF (INUSUG.EQ.4) THEN
47973               WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47974      &             //' M(ur), M(el), M(er):'
47975               READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47976      &             XNUSUG(10),XNUSUG(9)
47977             ELSEIF (INUSUG.EQ.5) THEN
47978               WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47979      &              //' M(Ll), M(Lr):'
47980               READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47981      &             XNUSUG(15),XNUSUG(14)
47982             ENDIF
47983             GOTO 110
47984           ENDIF
47985         ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47986           IMSS(11)=1
47987           WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47988      &         ,' sgn(mu), M_t, C_gv:'
47989           READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47990           XGMIN(7)=XCMGV
47991           XGMIN(8)=1.
47992 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47993           AMPL=2.4D18
47994           AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47995           IF (IMODEL.EQ.5) THEN
47996             IMODEL=2
47997             WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47998      &           ,' masses at M_mes'
47999             WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
48000      &           ,' shifts at M_mes'
48001             WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
48002      &           ' Y at M_mes'
48003             WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
48004      &           ,'SU(2),SU(3)'
48005             WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
48006      &           ,' n5_2, n5_3'
48007             READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
48008      $           XGMIN(13),XGMIN(14)
48009           ENDIF
48010         ELSE
48011           WRITE(MSTU(11),*) 'Invalid model choice.'
48012           GOTO 9999
48013         ENDIF
48014       ENDIF
48015  
48016  120  MZERO=M0
48017       MHLF=MHF
48018       AZERO=A0
48019 C     TANB=REAL(RMSS(5))
48020 C     SGNMU=REAL(RMSS(4))
48021       MTOP=MT
48022  
48023 C...Initialize MSSM parameter array
48024  130  DO 140 IPAR=1,72
48025         SUPER(IPAR)=0.0
48026  140  CONTINUE
48027 C...Call ISASUGRA
48028       CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
48029 C...Check whether ISASUSY thought the model was OK.
48030       IF (NOGOOD.NE.0) THEN
48031         IF (NOGOOD.EQ.1) CALL PYERRM(26
48032      &       ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
48033         IF (NOGOOD.EQ.2) CALL PYERRM(26
48034      &       ,'(PYSUGI:) SUSY parameters give no EWSB.')
48035         IF (NOGOOD.EQ.3) CALL PYERRM(26
48036      &       ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
48037         IF (NOGOOD.EQ.4) CALL PYERRM(26
48038      &       ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
48039         IF (NOGOOD.EQ.7) CALL PYERRM(26
48040      &       ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
48041         IF (NOGOOD.EQ.8) CALL PYERRM(26
48042      &       ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
48043 C...Give warning, but don't stop, if LSP not ~chi_10.
48044         IF (NOGOOD.EQ.5) CALL PYERRM(16
48045      &       ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
48046       ENDIF
48047 C...Warn about possible GUT scale tachyons.
48048       IF (ITACHY.NE.0) CALL PYERRM(16,
48049      &       '(PYSUGI:) Tachyonic sleptons at GUT scale.')
48050 C...Finalize spectrum (last iteration)
48051 C...(Thanks to A. Raklev for pointing this out.)
48052 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
48053       CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
48054      $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
48055      $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
48056      $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
48057      $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
48058      $ MTOP,IALLOW,1)
48059  
48060 C...M1, M2, M3.
48061       RMSS(1)=dble(GSS(7))
48062       RMSS(2)=dble(GSS(8))
48063       RMSS(3)=dble(GSS(9))
48064       RMSOFT(1)=dble(GSS(7))
48065       RMSOFT(2)=dble(GSS(8))
48066       RMSOFT(3)=dble(GSS(9))
48067 C...Mu = - Higgsino mass.
48068       RMSS(4)=-SUPER(29)
48069       RMSS(5)=TANB
48070 C...Slepton and squark masses. 2 first generations.
48071       RMSS(6)=0.5*(SUPER(18)+SUPER(20))
48072       RMSS(7)=0.5*(SUPER(19)+SUPER(21))
48073       RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
48074       RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
48075 C...Third generation.
48076       RMSS(10)=0.5*(SUPER(14)+SUPER(10))
48077       RMSS(11)=SUPER(11)
48078       RMSS(12)=SUPER(15)
48079       RMSS(13)=SUPER(22)
48080       RMSS(14)=SUPER(23)
48081 C...SLHA: store exact soft spectrum in RMSOFT
48082       RMSOFT(31)=SUPER(18)
48083       RMSOFT(32)=SUPER(20)
48084       RMSOFT(33)=SUPER(22)
48085       RMSOFT(34)=SUPER(19)
48086       RMSOFT(35)=SUPER(21)
48087       RMSOFT(36)=SUPER(23)
48088       RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
48089       RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
48090       RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
48091       RMSOFT(44)=SUPER(3)
48092       RMSOFT(45)=SUPER(9)
48093       RMSOFT(46)=SUPER(15)
48094       RMSOFT(47)=SUPER(5)
48095       RMSOFT(48)=SUPER(7)
48096       RMSOFT(49)=SUPER(11)
48097  
48098 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
48099       RMSS(15)=SUPER(62)
48100       RMSS(16)=SUPER(60)
48101       RMSS(17)=SUPER(64)
48102       RMSS(26)=SUPER(63)
48103       RMSS(27)=SUPER(61)
48104       RMSS(28)=SUPER(65)
48105 C...SLHA trilinears
48106       DO 142 K1=1,3
48107         DO 141 K2=1,3
48108           AE(K1,K2)=0D0
48109           AU(K1,K2)=0D0
48110           AD(K1,K2)=0D0
48111  141    CONTINUE
48112  142  CONTINUE
48113       AE(3,3)=SUPER(64)
48114       AU(3,3)=SUPER(60)
48115       AD(3,3)=SUPER(62)
48116 C...Higgs mixing angle alpha (Gunion-Haber convention).
48117       RMSS(18)=-SUPER(59)
48118 C...A0 mass.
48119       RMSS(19)=SUPER(57)
48120 C...GUT scale coupling
48121       RMSS(20)=AGUTSS
48122 C...Gravitino mass (for future compatibility)
48123       RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
48124  
48125 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
48126 C...Higgs sector.
48127       PMAS(PYCOMP(25),1)=ABS(SUPER(55))
48128       PMAS(PYCOMP(35),1)=ABS(SUPER(56))
48129       PMAS(PYCOMP(36),1)=ABS(SUPER(57))
48130       PMAS(PYCOMP(37),1)=ABS(SUPER(58))
48131 C...Gluino.
48132       PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
48133 C...Squarks and Sleptons.
48134       DO 150 ILR=1,2
48135         ILRM=ILR-1
48136         PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
48137         PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
48138         PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
48139         PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
48140         PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
48141         PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
48142         PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
48143         PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
48144         PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
48145   150 CONTINUE
48146       PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
48147       PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
48148       PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
48149 C...Neutralinos.
48150       PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
48151       PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
48152       PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
48153       PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
48154 C...Signed masses (extra minus from going to G-H convention).
48155       SMZ(1)=-SUPER(31)
48156       SMZ(2)=-SUPER(32)
48157       SMZ(3)=-SUPER(33)
48158       SMZ(4)=-SUPER(34)
48159 C...Charginos
48160       PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
48161       PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
48162 C...Signed masses (extra minus from going to G-H convention).
48163       SMW(1)=-SUPER(51)
48164       SMW(2)=-SUPER(52)
48165  
48166 C... Neutralino Mixing.
48167       DO 160 IN=1,4
48168         ZMIX(IN,1)= SUPER(38+4*(IN-1))
48169         ZMIX(IN,2)= SUPER(37+4*(IN-1))
48170         ZMIX(IN,3)=-SUPER(36+4*(IN-1))
48171         ZMIX(IN,4)=-SUPER(35+4*(IN-1))
48172   160 CONTINUE
48173 C...Chargino Mixing (PYTHIA same angle as HERWIG).
48174       THX=1D0
48175       THY=1D0
48176       IF (SUPER(53).GT.0) THX=-1D0
48177       IF (SUPER(54).GT.0) THY=-1D0
48178       UMIX(1,1) = -SIN(SUPER(53))
48179       UMIX(1,2) = -COS(SUPER(53))
48180       UMIX(2,1) = -THX*COS(SUPER(53))
48181       UMIX(2,2) = THX*SIN(SUPER(53))
48182       VMIX(1,1) = -SIN(SUPER(54))
48183       VMIX(1,2) = -COS(SUPER(54))
48184       VMIX(2,1) = -THY*COS(SUPER(54))
48185       VMIX(2,2) = THY*SIN(SUPER(54))
48186 C...Sfermion mixing (PYTHIA same angle as ISAJET)
48187       SFMIX(5,1)=COS(SUPER(63))
48188       SFMIX(5,2)=SIN(SUPER(63))
48189       SFMIX(5,3)=-SIN(SUPER(63))
48190       SFMIX(5,4)=COS(SUPER(63))
48191       SFMIX(6,1)=COS(SUPER(61))
48192       SFMIX(6,2)=SIN(SUPER(61))
48193       SFMIX(6,3)=-SIN(SUPER(61))
48194       SFMIX(6,4)=COS(SUPER(61))
48195       SFMIX(15,1)=COS(SUPER(65))
48196       SFMIX(15,2)=SIN(SUPER(65))
48197       SFMIX(15,3)=-SIN(SUPER(65))
48198       SFMIX(15,4)=COS(SUPER(65))
48199  
48200       IF (MSTP(122).NE.0) THEN
48201 C...Print a few lines to make the user know what's happening
48202         ISAVER=VISAJE()
48203         WRITE(MSTU(11),5000) DOC, ISAVER
48204         WRITE(MSTU(11),5100)
48205         IF (IMODEL.EQ.1) THEN
48206           WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
48207      &         MTOP
48208           WRITE(MSTU(11),5300)
48209         ENDIF
48210         WRITE(MSTU(11),5500) 'Pole masses'
48211         WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
48212         WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
48213      &       ,(SUPER(IP),IP=19,25,2)
48214         WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
48215      &       ,IP=1,2)
48216         WRITE(MSTU(11),5400)
48217         WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
48218         WRITE(MSTU(11),5400)
48219         WRITE(MSTU(11),5500) 'EW scale mixing structure'
48220         WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
48221         WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
48222      &       ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
48223         WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
48224      &       ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
48225      &       ),(SFMIX(15,J),J=3,4)
48226         WRITE(MSTU(11),5400)
48227         WRITE(MSTU(11),6450) RMSS(18)
48228         WRITE(MSTU(11),5400)
48229         WRITE(MSTU(11),5500) 'Couplings'
48230         WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
48231         WRITE(MSTU(11),5400)
48232       ENDIF
48233  
48234 C...Call FeynHiggs to improve Higgs sector if requested
48235       IF (IMSS(4).EQ.3) THEN
48236         IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
48237      &       ' (PYSUGI:) Now calling FeynHiggs.'
48238         CALL PYFEYN(IERR)
48239         IF (IERR.EQ.0) THEN
48240           IMSS(4)=2
48241           IF (MSTP(122).NE.0) THEN
48242             WRITE(MSTU(11),5400)
48243             WRITE(MSTU(11),5500)
48244      &           'Corrected Higgs masses and mixing'
48245             WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
48246      &           PMAS(37,1)
48247             WRITE(MSTU(11),6450) RMSS(18)
48248             WRITE(MSTU(11),5400)
48249           ENDIF
48250         ENDIF
48251       ENDIF
48252  
48253       IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
48254  
48255 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
48256 C...output by ISASUSY.
48257       IMSS(4)=MAX(2,IMSS(4))
48258  
48259  5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
48260      &     ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
48261      &     ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
48262  5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
48263  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
48264      &     3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
48265  5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
48266      &     ,'----------------')
48267  5400 FORMAT(1x,'*',1x,A)
48268  5500 FORMAT(1x,'*',1x,A,':')
48269  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
48270      &       1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
48271  5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
48272      &     4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
48273      &     '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
48274      &     ,1x))
48275  5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
48276      &     ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
48277      &     ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
48278      &     .2,1x))
48279  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
48280      &     ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
48281      &     ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
48282  6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48283      &     ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
48284  6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48285      &     ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
48286  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
48287      &     ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
48288      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
48289      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
48290      &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
48291      &     ,1x,F6.3,1x),'|')
48292  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
48293      &     ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
48294      &     ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
48295      &     ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
48296      &     ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
48297  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
48298      &     ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
48299      &     ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
48300      &     1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
48301      &     ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
48302      &     1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
48303      &     ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
48304  6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
48305      &     ,4x,'Alpha_GUT = ',F8.2)
48306  6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
48307  6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
48308  
48309  9999 RETURN
48310       END
48311  
48312 C*********************************************************************
48313  
48314 C...PYFEYN
48315 C...Interface to FeynHiggs for MSSM Higgs sector.
48316 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
48317 C...P. Skands
48318  
48319       SUBROUTINE PYFEYN(IERR)
48320  
48321 C...Double precision and integer declarations.
48322       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48323       IMPLICIT INTEGER(I-N)
48324       INTEGER PYK,PYCHGE,PYCOMP
48325 C...Commonblocks.
48326       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48327       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48328 C...SUSY blocks
48329       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48330 C...FeynHiggs variables
48331       DOUBLE PRECISION RMHIGG(4)
48332       DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
48333       DOUBLE COMPLEX DMU,
48334      &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48335      &     DM1, DM2, DM3
48336 C...SLHA Common Block
48337       COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
48338      &     AU(3,3),AD(3,3),AE(3,3)
48339       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
48340  
48341       IERR=0
48342       CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
48343       IF (IERR.NE.0) THEN
48344         CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
48345      &       //'Will not use FeynHiggs for this run.')
48346         RETURN
48347       ENDIF
48348       Q=RMSOFT(0)
48349       DMB=PMAS(5,1)
48350       DMT=PMAS(6,1)
48351       DMZ=PMAS(23,1)
48352       DMW=PMAS(24,1)
48353       DMA=PMAS(36,1)
48354       DM1=RMSOFT(1)
48355       DM2=RMSOFT(2)
48356       DM3=RMSOFT(3)
48357       DTANB=RMSS(5)
48358       DMU=RMSS(4)
48359       DM3SL=RMSOFT(33)
48360       DM3SE=RMSOFT(36)
48361       DM3SQ=RMSOFT(43)
48362       DM3SU=RMSOFT(46)
48363       DM3SD=RMSOFT(49)
48364       DM2SL=RMSOFT(32)
48365       DM2SE=RMSOFT(35)
48366       DM2SQ=RMSOFT(42)
48367       DM2SU=RMSOFT(45)
48368       DM2SD=RMSOFT(48)
48369       DM1SL=RMSOFT(31)
48370       DM1SE=RMSOFT(34)
48371       DM1SQ=RMSOFT(41)
48372       DM1SU=RMSOFT(44)
48373       DM1SD=RMSOFT(47)
48374       AE33=AE(3,3)
48375       AE22=AE(2,2)
48376       AE11=AE(1,1)
48377       AU33=AU(3,3)
48378       AU22=AU(2,2)
48379       AU11=AU(1,1)
48380       AD33=AD(3,3)
48381       AD22=AD(2,2)
48382       AD11=AD(1,1)
48383       CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
48384      &     DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
48385      &     DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
48386      &     DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
48387      &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48388      &     DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
48389       IF (IERR.NE.0) THEN
48390         CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
48391      &       //' Will not use FeynHiggs for this run.')
48392         RETURN
48393       ENDIF
48394 C...  Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
48395       SAEFF=0D0
48396       CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
48397       IF (IERR.NE.0) THEN
48398         CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
48399      &       'GSCORR. Will not use FeynHiggs for this run.')
48400         RETURN
48401       ENDIF
48402       ALPHA = ASIN(DBLE(SAEFF))
48403       R=RMSS(18)/ALPHA
48404       IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
48405         CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48406         WRITE(MSTU(11),*) '   Old Alpha:', RMSS(18)
48407         WRITE(MSTU(11),*) '   New Alpha:', ALPHA
48408       ENDIF
48409       IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
48410      &       1.15D0*PMAS(25,1)) THEN
48411         CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48412         WRITE(MSTU(11),*) '   Old m(h0):', PMAS(25,1)
48413         WRITE(MSTU(11),*) '   New m(h0):', RMHIGG(1)
48414       ENDIF
48415       RMSS(18)=ALPHA
48416       PMAS(25,1)=RMHIGG(1)
48417       PMAS(35,1)=RMHIGG(2)
48418       PMAS(36,1)=RMHIGG(3)
48419       PMAS(37,1)=RMHIGG(4)
48420  
48421       RETURN
48422       END
48423  
48424 C*********************************************************************
48425  
48426 C...PYRNMQ
48427 C...Determines the running mass of Squarks.
48428  
48429       FUNCTION PYRNMQ(ID,DTERM)
48430  
48431 C...Double precision and integer declarations.
48432       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48433       IMPLICIT INTEGER(I-N)
48434       INTEGER PYK,PYCHGE,PYCOMP
48435 C...Commonblock.
48436       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48437       SAVE /PYMSSM/
48438  
48439 C...Local variables.
48440       DOUBLE PRECISION PI,R
48441       DOUBLE PRECISION TOL
48442       DOUBLE PRECISION CI(3)
48443       EXTERNAL PYALPS
48444       DOUBLE PRECISION PYALPS
48445       DATA TOL/0.001D0/
48446       DATA PI,R/3.141592654D0,.61803399D0/
48447       DATA CI/0.47D0,0.07D0,0.02D0/
48448  
48449       C=1D0-R
48450       CA=CI(ID)
48451       AG=(0.71D0)**2/4D0/PI
48452       AG=RMSS(20)
48453       XM0=RMSS(8)
48454       XMG=RMSS(1)
48455       XM02=XM0*XM0
48456       XMG2=XMG*XMG
48457  
48458       AS=PYALPS(XM02+6D0*XMG2)
48459       CG=8D0/9D0*((AS/AG)**2-1D0)
48460       BX=XM02+(CA+CG)*XMG2+DTERM
48461       AX=MIN(50D0**2,0.5D0*BX)
48462       CX=MAX(2000D0**2,2D0*BX)
48463  
48464       X0=AX
48465       X3=CX
48466       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48467         X1=BX
48468         X2=BX+C*(CX-BX)
48469       ELSE
48470         X2=BX
48471         X1=BX-C*(BX-AX)
48472       ENDIF
48473       AS1=PYALPS(X1)
48474       CG=8D0/9D0*((AS1/AG)**2-1D0)
48475       F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48476       AS2=PYALPS(X2)
48477       CG=8D0/9D0*((AS2/AG)**2-1D0)
48478       F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48479   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48480         IF(F2.LT.F1) THEN
48481           X0=X1
48482           X1=X2
48483           X2=R*X1+C*X3
48484           F1=F2
48485           AS2=PYALPS(X2)
48486           CG=8D0/9D0*((AS2/AG)**2-1D0)
48487           F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48488         ELSE
48489           X3=X2
48490           X2=X1
48491           X1=R*X2+C*X0
48492           F2=F1
48493           AS1=PYALPS(X1)
48494           CG=8D0/9D0*((AS1/AG)**2-1D0)
48495           F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48496         ENDIF
48497         GOTO 100
48498       ENDIF
48499       IF(F1.LT.F2) THEN
48500         PYRNMQ=X1
48501         XMIN=X1
48502       ELSE
48503         PYRNMQ=X2
48504         XMIN=X2
48505       ENDIF
48506  
48507       RETURN
48508       END
48509  
48510 C*********************************************************************
48511  
48512 C...PYTHRG
48513 C...Calculates the mass eigenstates of the third generation sfermions.
48514 C...Created:  5-31-96
48515  
48516       SUBROUTINE PYTHRG
48517  
48518 C...Double precision and integer declarations.
48519       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48520       IMPLICIT INTEGER(I-N)
48521       INTEGER PYK,PYCHGE,PYCOMP
48522 C...Parameter statement to help give large particle numbers.
48523       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48524      &KEXCIT=4000000,KDIMEN=5000000)
48525 C...Commonblocks.
48526       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48527       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48528       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48529       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48530      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48531       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48532  
48533 C...Local variables.
48534       DOUBLE PRECISION BETA
48535       DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
48536       DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
48537       DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
48538       DOUBLE PRECISION ATR,AMQR,AMQL
48539       INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
48540       INTEGER IF,I,J,II,JJ,IT,L
48541       LOGICAL DTERM
48542       DATA SMALL/1D-3/
48543       DATA ID1/10,10,13/
48544       DATA ID2/5,6,15/
48545       DATA ID3/15,16,17/
48546       DATA ID4/11,12,14/
48547       DATA DTERM/.TRUE./
48548  
48549       XMZ2=PMAS(23,1)**2
48550       XMW2=PMAS(24,1)**2
48551       TANB=RMSS(5)
48552       XMU=-RMSS(4)
48553       BETA=ATAN(TANB)
48554       COS2B=COS(2D0*BETA)
48555  
48556 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
48557  
48558       IOPT=IMSS(5)
48559       IF(IOPT.EQ.1) THEN
48560         CTT=DCOS(RMSS(27))
48561         CTT2=CTT**2
48562         STT=DSIN(RMSS(27))
48563         STT2=STT**2
48564         XM12=RMSS(10)**2
48565         XM22=RMSS(12)**2
48566         XMQL2=CTT2*XM12+STT2*XM22
48567         XMQR2=STT2*XM12+CTT2*XM22
48568         XMF2=PYMRUN(6,PMAS(6,1)**2)**2
48569         ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48570         RMSS(16)=ATOP
48571 C......SUBTRACT OUT D-TERM AND FERMION MASS
48572         XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
48573         XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
48574         IF(XMQL2.GE.0D0) THEN
48575           RMSS(10)=SQRT(XMQL2)
48576         ELSE
48577           RMSS(10)=-SQRT(-XMQL2)
48578         ENDIF
48579         IF(XMQR2.GE.0D0) THEN
48580           RMSS(12)=SQRT(XMQR2)
48581         ELSE
48582           RMSS(12)=-SQRT(-XMQR2)
48583         ENDIF
48584  
48585 C SAME FOR BOTTOM SQUARK
48586         CTT=DCOS(RMSS(26))
48587         CTT2=CTT**2
48588         STT=DSIN(RMSS(26))
48589         STT2=STT**2
48590         XM22=RMSS(11)**2
48591         XMF2=PYMRUN(5,PMAS(6,1)**2)**2
48592         XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
48593         IF(ABS(CTT).GE..9999D0) THEN
48594           ABOT=-XMU*TANB
48595           XMQR2=RMSS(11)**2
48596         ELSEIF(ABS(CTT).LE.1D-4) THEN
48597           ABOT=-XMU*TANB
48598           XMQR2=RMSS(11)**2
48599         ELSE
48600           XM12=(XMQL2-STT2*XM22)/CTT2
48601           XMQR2=STT2*XM12+CTT2*XM22
48602           ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48603         ENDIF
48604         RMSS(15)=ABOT
48605 C......SUBTRACT OUT D-TERM AND FERMION MASS
48606         XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
48607         IF(XMQR2.GE.0D0) THEN
48608           RMSS(11)=SQRT(XMQR2)
48609         ELSE
48610           RMSS(11)=-SQRT(-XMQR2)
48611         ENDIF
48612 C SAME FOR TAU SLEPTON
48613         CTT=DCOS(RMSS(28))
48614         CTT2=CTT**2
48615         STT=DSIN(RMSS(28))
48616         STT2=STT**2
48617         XM12=RMSS(13)**2
48618         XM22=RMSS(14)**2
48619         XMQL2=CTT2*XM12+STT2*XM22
48620         XMQR2=STT2*XM12+CTT2*XM22
48621         XMFR=PMAS(15,1)
48622         XMF2=XMFR**2
48623         ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48624         RMSS(17)=ATAU
48625 C......SUBTRACT OUT D-TERM AND FERMION MASS
48626         XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
48627         XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
48628         IF(XMQL2.GE.0D0) THEN
48629           RMSS(13)=SQRT(XMQL2)
48630         ELSE
48631           RMSS(13)=-SQRT(-XMQL2)
48632         ENDIF
48633         IF(XMQR2.GE.0D0) THEN
48634           RMSS(14)=SQRT(XMQR2)
48635         ELSE
48636           RMSS(14)=-SQRT(-XMQR2)
48637         ENDIF
48638       ENDIF
48639       DO 170 L=1,3
48640         AMQL=RMSS(ID1(L))
48641         IF(AMQL.LT.0D0) THEN
48642           XMQL2=-AMQL**2
48643         ELSE
48644           XMQL2=AMQL**2
48645         ENDIF
48646         ATR=RMSS(ID3(L))
48647         AMQR=RMSS(ID4(L))
48648         IF(AMQR.LT.0D0) THEN
48649           XMQR2=-AMQR**2
48650         ELSE
48651           XMQR2=AMQR**2
48652         ENDIF
48653         IF=ID2(L)
48654         XMF=PYMRUN(IF,PMAS(6,1)**2)
48655         XMF2=XMF**2
48656         AM2(1,1)=XMQL2+XMF2
48657         AM2(2,2)=XMQR2+XMF2
48658         IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
48659         IF(DTERM) THEN
48660           IF(L.EQ.1) THEN
48661             AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
48662             AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
48663             AM2(1,2)=XMF*(ATR+XMU*TANB)
48664           ELSEIF(L.EQ.2) THEN
48665             AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
48666             AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
48667             AM2(1,2)=XMF*(ATR+XMU/TANB)
48668           ELSEIF(L.EQ.3) THEN
48669             IF(IMSS(8).EQ.1) THEN
48670               AM2(1,1)=RMSS(6)**2
48671               AM2(2,2)=RMSS(7)**2
48672               AM2(1,2)=0D0
48673               RMSS(13)=RMSS(6)
48674               RMSS(14)=RMSS(7)
48675             ELSE
48676               AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
48677               AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
48678               AM2(1,2)=XMF*(ATR+XMU*TANB)
48679             ENDIF
48680           ENDIF
48681         ENDIF
48682         AM2(2,1)=AM2(1,2)
48683         DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
48684         IF(DETM.LT.0D0) THEN
48685           WRITE(MSTU(11),*) ID2(L),DETM,AM2
48686           CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
48687         ENDIF
48688         SAME=0.5D0*(AM2(1,1)+AM2(2,2))
48689         DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
48690         XMF12=SAME-DIFF
48691         XMF22=SAME+DIFF
48692         IT=0
48693         IF(XMF22-XMF12.GT.0D0) THEN
48694           RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
48695           RT(2,2) = RT(1,1)
48696           RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
48697      &    AM2(1,2)/(XMF22-XMF12))
48698           RT(2,1) = -RT(1,2)
48699         ELSE
48700           RT(1,1) = 1D0
48701           RT(2,2) = RT(1,1)
48702           RT(1,2) = 0D0
48703           RT(2,1) = -RT(1,2)
48704         ENDIF
48705   100   CONTINUE
48706         IT=IT+1
48707  
48708         DO 140 I=1,2
48709           DO 130 JJ=1,2
48710             DI(I,JJ)=0D0
48711             DO 120 II=1,2
48712               DO 110 J=1,2
48713                 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
48714   110         CONTINUE
48715   120       CONTINUE
48716   130     CONTINUE
48717   140   CONTINUE
48718  
48719         IF(DI(1,1).GT.DI(2,2)) THEN
48720           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
48721           WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
48722           WRITE(MSTU(11),*) AM2
48723           WRITE(MSTU(11),*) DI
48724           WRITE(MSTU(11),*) RT
48725           DI(1,1)=-RT(2,1)
48726           DI(2,2)=RT(1,2)
48727           DI(1,2)=-RT(2,2)
48728           DI(2,1)=RT(1,1)
48729           DO 160 I=1,2
48730             DO 150 J=1,2
48731               RT(I,J)=DI(I,J)
48732   150       CONTINUE
48733   160     CONTINUE
48734           GOTO 100
48735         ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
48736           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48737      &    ' OFF DIAGONAL ELEMENTS '
48738           WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
48739           WRITE(MSTU(11),*) DI
48740           WRITE(MSTU(11),*) ' ROTATION = ',RT
48741 C...STOP
48742         ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
48743           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48744      &    ' NEGATIVE MASSES '
48745           CALL PYSTOP(111)
48746         ENDIF
48747         PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
48748         PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
48749         SFMIX(IF,1)=RT(1,1)
48750         SFMIX(IF,2)=RT(1,2)
48751         SFMIX(IF,3)=RT(2,1)
48752         SFMIX(IF,4)=RT(2,2)
48753   170 CONTINUE
48754  
48755 C.....TAU SNEUTRINO MASS...L=3
48756  
48757       XARG=AM2(1,1)+XMW2*COS2B
48758       IF(XARG.LT.0D0) THEN
48759         WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
48760      &  ' FROM THE SUM RULE. '
48761         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
48762         RETURN
48763       ELSE
48764         PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
48765       ENDIF
48766  
48767       RETURN
48768       END
48769 C*********************************************************************
48770  
48771 C...PYINOM
48772 C...Finds the mass eigenstates and mixing matrices for neutralinos
48773 C...and charginos.
48774  
48775       SUBROUTINE PYINOM
48776  
48777 C...Double precision and integer declarations.
48778       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48779       IMPLICIT INTEGER(I-N)
48780       INTEGER PYCOMP
48781 C...Parameter statement to help give large particle numbers.
48782       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48783      &KEXCIT=4000000,KDIMEN=5000000)
48784 C...Commonblocks.
48785       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48786       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48787       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48788       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48789      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48790       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48791  
48792 C...Local variables.
48793       DOUBLE PRECISION XMW,XMZ,XM(4)
48794       DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
48795       DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
48796       DOUBLE PRECISION COSW,SINW
48797       DOUBLE PRECISION XMU
48798       DOUBLE PRECISION TANB,COSB,SINB
48799       DOUBLE PRECISION XM1,XM2,XM3,BETA
48800       DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
48801       DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
48802       DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
48803       DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
48804       DOUBLE PRECISION PYALPS,PYALEM
48805       DOUBLE PRECISION PYRNM3
48806       COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
48807       INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
48808       DATA KFNCHI/1000022,1000023,1000025,1000035/
48809  
48810       IOPT=IMSS(2)
48811       IF(IMSS(1).EQ.2) THEN
48812         IOPT=1
48813       ENDIF
48814 C...M1, M2, AND M3 ARE INDEPENDENT
48815       IF(IOPT.EQ.0) THEN
48816         XM1=RMSS(1)
48817         XM2=RMSS(2)
48818         XM3=RMSS(3)
48819       ELSEIF(IOPT.GE.1) THEN
48820         Q2=PMAS(23,1)**2
48821         AEM=PYALEM(Q2)
48822         A2=AEM/PARU(102)
48823         A1=AEM/(1D0-PARU(102))
48824         XM1=RMSS(1)
48825         XM2=RMSS(2)
48826         IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
48827         IF(IOPT.EQ.1) THEN
48828           XM2=XM1*A2/A1*3D0/5D0
48829           RMSS(2)=XM2
48830         ELSEIF(IOPT.EQ.3) THEN
48831           XM1=XM2*5D0/3D0*A1/A2
48832           RMSS(1)=XM1
48833         ENDIF
48834         XM3=PYRNM3(XM2/A2)
48835         RMSS(3)=XM3
48836         IF(XM3.LE.0D0) THEN
48837           WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
48838           CALL PYSTOP(105)
48839         ENDIF
48840       ENDIF
48841  
48842 C...GLUINO MASS
48843       IF(IMSS(3).EQ.1) THEN
48844         PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48845       ELSE
48846         AQ=0D0
48847         DO 110 I=1,4
48848           DO 100 ILR=1,2
48849             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48850             AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48851      &      +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48852   100     CONTINUE
48853   110   CONTINUE
48854  
48855         DO 130 I=5,6
48856           DO 120 ILR=1,2
48857             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48858             RM2=PMAS(I,1)**2/XM3**2
48859             ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48860             IF(ARG.GE.0D0) THEN
48861               X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48862               AX0=ABS(X0)
48863               X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48864               AX1=ABS(X1)
48865               IF(X0.EQ.1D0) THEN
48866                 AT=-1D0
48867                 BT=0.25D0
48868               ELSEIF(X0.EQ.0D0) THEN
48869                 AT=0D0
48870                 BT=-0.25D0
48871               ELSE
48872                 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48873      &          0.5D0*X0**2*LOG(AX0)
48874                 BT=(-1D0-2D0*X0)/4D0
48875               ENDIF
48876               IF(X1.EQ.1D0) THEN
48877                 AT=-1D0+AT
48878                 BT=0.25D0+BT
48879               ELSEIF(X1.EQ.0D0) THEN
48880                 AT=0D0+AT
48881                 BT=-0.25D0+BT
48882               ELSE
48883                 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48884      &          X1**2*LOG(AX1)+AT
48885                 BT=(-1D0-2D0*X1)/4D0+BT
48886               ENDIF
48887               AQ=AQ+AT+BT
48888             ELSE
48889               X0=0.5D0*(1D0+RM2-RM1)
48890               Y0=-0.5D0*SQRT(-ARG)
48891               AMGX0=SQRT(X0**2+Y0**2)
48892               AM1X0=SQRT((1D0-X0)**2+Y0**2)
48893               ARGX0=ATAN2(-X0,-Y0)
48894               AR1X0=ATAN2(1D0-X0,Y0)
48895               X1=X0
48896               Y1=-Y0
48897               AMGX1=AMGX0
48898               AM1X1=AM1X0
48899               ARGX1=ATAN2(-X1,-Y1)
48900               AR1X1=ATAN2(1D0-X1,Y1)
48901               AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48902      &        +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48903               BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48904               AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48905      &        +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48906               BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48907               AQ=AQ+AT+BT
48908             ENDIF
48909   120     CONTINUE
48910   130   CONTINUE
48911         PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48912      &  /(2D0*PARU(2))*(15D0+AQ))
48913       ENDIF
48914  
48915 C...NEUTRALINO MASSES
48916       DO 150 I=1,4
48917         DO 140 J=1,4
48918           AI(I,J)=0D0
48919   140   CONTINUE
48920   150 CONTINUE
48921       XMZ=PMAS(23,1)/100D0
48922       XMW=PMAS(24,1)/100D0
48923       XMU=RMSS(4)/100D0
48924       SINW=SQRT(PARU(102))
48925       COSW=SQRT(1D0-PARU(102))
48926       TANB=RMSS(5)
48927       BETA=ATAN(TANB)
48928       COSB=COS(BETA)
48929       SINB=TANB*COSB
48930 
48931       XM2=XM2/100D0
48932       XM1=XM1/100D0
48933       
48934  
48935 C... Definitions:
48936 C...    psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48937 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48938       AR(1,1) = XM1*COS(RMSS(30))
48939       AI(1,1) = XM1*SIN(RMSS(30))
48940       AR(2,2) = XM2*COS(RMSS(31))
48941       AI(2,2) = XM2*SIN(RMSS(31))
48942       AR(3,3) = 0D0
48943       AR(4,4) = 0D0
48944       AR(1,2) = 0D0
48945       AR(2,1) = 0D0
48946       AR(1,3) = -XMZ*SINW*COSB
48947       AR(3,1) = AR(1,3)
48948       AR(1,4) = XMZ*SINW*SINB
48949       AR(4,1) = AR(1,4)
48950       AR(2,3) = XMZ*COSW*COSB
48951       AR(3,2) = AR(2,3)
48952       AR(2,4) = -XMZ*COSW*SINB
48953       AR(4,2) = AR(2,4)
48954       AR(3,4) = -XMU*COS(RMSS(33))
48955       AI(3,4) = -XMU*SIN(RMSS(33))
48956       AR(4,3) = -XMU*COS(RMSS(33))
48957       AI(4,3) = -XMU*SIN(RMSS(33))
48958 C      CALL PYEIG4(AR,WR,ZR)
48959       CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48960       IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48961      & 'PROBLEM WITH PYEICG IN PYINOM ')
48962       DO 160 I=1,4
48963         INDEX(I)=I
48964         XM(I)=ABS(WR(I))
48965   160 CONTINUE
48966       DO 180 I=2,4
48967         K=I
48968         DO 170 J=I-1,1,-1
48969           IF(XM(K).LT.XM(J)) THEN
48970             ITMP=INDEX(J)
48971             XTMP=XM(J)
48972             INDEX(J)=INDEX(K)
48973             XM(J)=XM(K)
48974             INDEX(K)=ITMP
48975             XM(K)=XTMP
48976             K=K-1
48977           ELSE
48978             GOTO 180
48979           ENDIF
48980   170   CONTINUE
48981   180 CONTINUE
48982  
48983  
48984       DO 210 I=1,4
48985         K=INDEX(I)
48986         SMZ(I)=WR(K)*100D0
48987         PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48988         S=0D0
48989         DO 190 J=1,4
48990           S=S+ZR(J,K)**2+ZI(J,K)**2
48991   190   CONTINUE
48992         DO 200 J=1,4
48993           ZMIX(I,J)=ZR(J,K)/SQRT(S)
48994           ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48995           IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48996           IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48997   200   CONTINUE
48998   210 CONTINUE
48999  
49000 C...CHARGINO MASSES
49001 C.....Find eigenvectors of X X^*
49002       DO I=1,4
49003         DO J=1,4
49004           AR(I,J)=0D0
49005           AI(I,J)=0D0
49006         ENDDO
49007       ENDDO
49008       AI(1,1) = 0D0
49009       AI(2,2) = 0D0
49010       AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
49011       AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
49012       AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
49013      &XMU*COS(RMSS(33))*SINB)
49014       AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
49015      &XMU*SIN(RMSS(33))*SINB)
49016       AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
49017      &XMU*COS(RMSS(33))*SINB)
49018       AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
49019      &XMU*SIN(RMSS(33))*SINB)
49020       CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
49021       IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
49022      & 'PROBLEM WITH PYEICG IN PYINOM ')
49023       INDEX(1)=1
49024       INDEX(2)=2
49025       IF(WR(2).LT.WR(1)) THEN
49026         INDEX(1)=2
49027         INDEX(2)=1
49028       ENDIF
49029 
49030  
49031       DO 240 I=1,2
49032         K=INDEX(I)
49033         SMW(I)=SQRT(WR(K))*100D0
49034         S=0D0
49035         DO 220 J=1,2
49036           S=S+ZR(J,K)**2+ZI(J,K)**2
49037   220   CONTINUE
49038         DO 230 J=1,2
49039           UMIX(I,J)=ZR(J,K)/SQRT(S)
49040           UMIXI(I,J)=-ZI(J,K)/SQRT(S)
49041           IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
49042           IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
49043   230   CONTINUE
49044   240 CONTINUE
49045 C...Force chargino mass > neutralino mass
49046       IFRC=0
49047       IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
49048         CALL PYERRM(8,'(PYINOM:) '//
49049      &      'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
49050         SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
49051         IFRC=1
49052       ENDIF
49053       PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
49054       PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
49055  
49056 C.....Find eigenvectors of X^* X
49057       DO I=1,4
49058         DO J=1,4
49059           AR(I,J)=0D0
49060           AI(I,J)=0D0
49061           ZR(I,J)=0D0
49062           ZI(I,J)=0D0
49063         ENDDO
49064       ENDDO
49065       AI(1,1) = 0D0
49066       AI(2,2) = 0D0
49067       AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
49068       AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
49069       AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49070      &XMU*COS(RMSS(33))*COSB)
49071       AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
49072      &XMU*SIN(RMSS(33))*COSB)
49073       AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49074      &XMU*COS(RMSS(33))*COSB)
49075       AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
49076      &XMU*SIN(RMSS(33))*COSB)
49077       CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
49078       IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
49079      & 'PROBLEM WITH PYEICG IN PYINOM ')
49080       INDEX(1)=1
49081       INDEX(2)=2
49082       IF(WR(2).LT.WR(1)) THEN
49083         INDEX(1)=2
49084         INDEX(2)=1
49085       ENDIF
49086  
49087       SIMAG=0D0
49088       DO 270 I=1,2
49089         K=INDEX(I)
49090         S=0D0
49091         DO 250 J=1,2
49092           S=S+ZR(J,K)**2+ZI(J,K)**2
49093           SIMAG=SIMAG+ZI(J,K)**2
49094   250   CONTINUE
49095         DO 260 J=1,2
49096           VMIX(I,J)=ZR(J,K)/SQRT(S)
49097           VMIXI(I,J)=-ZI(J,K)/SQRT(S)
49098           IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
49099           IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
49100   260   CONTINUE
49101   270 CONTINUE
49102 
49103 C.....Simplify if no phases
49104       IF(SIMAG.LT.1D-6) THEN
49105         AR(1,1) = XM2*COS(RMSS(31))
49106         AR(2,2) = XMU*COS(RMSS(33))
49107         AR(1,2) = SQRT(2D0)*XMW*SINB
49108         AR(2,1) = SQRT(2D0)*XMW*COSB
49109         IKNT=0
49110  300    CONTINUE
49111         DO I=1,2
49112           DO J=1,2
49113             ZR(I,J)=0D0
49114           ENDDO
49115         ENDDO
49116 
49117         DO I=1,2
49118           DO J=1,2
49119             DO K=1,2
49120               DO L=1,2
49121                 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
49122               ENDDO
49123             ENDDO
49124           ENDDO
49125         ENDDO
49126         VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
49127         VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
49128         VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
49129         VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
49130         IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49131           CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49132         ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
49133           IKNT=IKNT+1
49134           GOTO 300
49135         ENDIF
49136 C.....Must deal with phases
49137       ELSE
49138         CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
49139         CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
49140         CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
49141         CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
49142 
49143         IKNT=0
49144  310    CONTINUE
49145         DO I=1,2
49146           DO J=1,2
49147             CAI(I,J)=CMPLX(0D0,0D0)
49148           ENDDO
49149         ENDDO
49150 
49151         DO I=1,2
49152           DO J=1,2
49153             DO K=1,2
49154               DO L=1,2
49155                 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
49156      &           CMPLX(VMIX(J,L),VMIXI(J,L))
49157               ENDDO
49158             ENDDO
49159           ENDDO
49160         ENDDO
49161 
49162         CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
49163         CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
49164         TEMPR=VMIX(1,1)
49165         TEMPI=VMIXI(1,1)
49166         VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49167         VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49168         TEMPR=VMIX(1,2)
49169         TEMPI=VMIXI(1,2)
49170         VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49171         VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49172         TEMPR=VMIX(2,1)
49173         TEMPI=VMIXI(2,1)
49174         VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49175         VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49176         TEMPR=VMIX(2,2)
49177         TEMPI=VMIXI(2,2)
49178         VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49179         VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49180         IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49181           CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49182         ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
49183      &   ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
49184           IKNT=IKNT+1
49185           GOTO 310
49186         ENDIF
49187       ENDIF 
49188       RETURN
49189       END
49190  
49191 C*********************************************************************
49192  
49193 C...PYRNM3
49194 C...Calculates the running of M3, the SU(3) gluino mass parameter.
49195  
49196       FUNCTION PYRNM3(RGUT)
49197  
49198 C...Double precision and integer declarations.
49199       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49200       IMPLICIT INTEGER(I-N)
49201       INTEGER PYK,PYCHGE,PYCOMP
49202  
49203 C...Local variables.
49204       DOUBLE PRECISION R
49205       DOUBLE PRECISION TOL
49206       EXTERNAL PYALPS
49207       DOUBLE PRECISION PYALPS
49208       DATA TOL/0.001D0/
49209       DATA R/0.61803399D0/
49210  
49211       C=1D0-R
49212  
49213       BX=RGUT*PYALPS(RGUT**2)
49214       AX=MIN(50D0,BX*0.5D0)
49215       CX=MAX(2000D0,2D0*BX)
49216  
49217       X0=AX
49218       X3=CX
49219       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
49220         X1=BX
49221         X2=BX+C*(CX-BX)
49222       ELSE
49223         X2=BX
49224         X1=BX-C*(BX-AX)
49225       ENDIF
49226       AS1=PYALPS(X1**2)
49227       F1=ABS(X1-RGUT*AS1)
49228       AS2=PYALPS(X2**2)
49229       F2=ABS(X2-RGUT*AS2)
49230   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
49231         IF(F2.LT.F1) THEN
49232           X0=X1
49233           X1=X2
49234           X2=R*X1+C*X3
49235           F1=F2
49236           AS2=PYALPS(X2**2)
49237           F2=ABS(X2-RGUT*AS2)
49238         ELSE
49239           X3=X2
49240           X2=X1
49241           X1=R*X2+C*X0
49242           F2=F1
49243           AS1=PYALPS(X1**2)
49244           F1=ABS(X1-RGUT*AS1)
49245         ENDIF
49246         GOTO 100
49247       ENDIF
49248       IF(F1.LT.F2) THEN
49249         PYRNM3=X1
49250         XMIN=X1
49251       ELSE
49252         PYRNM3=X2
49253         XMIN=X2
49254       ENDIF
49255  
49256       RETURN
49257       END
49258  
49259 C*********************************************************************
49260  
49261 C...PYEIG4
49262 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
49263 C...Specific application: mixing in neutralino sector.
49264  
49265       SUBROUTINE PYEIG4(A,W,Z)
49266  
49267 C...Double precision and integer declarations.
49268       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49269       IMPLICIT INTEGER(I-N)
49270       INTEGER PYK,PYCHGE,PYCOMP
49271  
49272 C...Arrays: in call and local.
49273       DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
49274  
49275 C...Coefficients of fourth-degree equation from matrix.
49276 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
49277       B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
49278       B2=0D0
49279       DO 110 I=1,3
49280         DO 100 J=I+1,4
49281           B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
49282   100   CONTINUE
49283   110 CONTINUE
49284       B1=0D0
49285       B0=0D0
49286       DO 120 I=1,4
49287         I1=MOD(I,4)+1
49288         I2=MOD(I+1,4)+1
49289         I3=MOD(I+2,4)+1
49290         B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
49291      &  A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
49292      &  A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
49293         B0=B0+(-1D0)**(I+1)*A(1,I)*(
49294      &  A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
49295      &  A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
49296      &  A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
49297   120 CONTINUE
49298  
49299 C...Coefficients of third-degree equation needed for
49300 C...separation into two second-degree equations.
49301 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
49302       C2=-B2
49303       C1=B1*B3-4D0*B0
49304       C0=-B1**2-B0*B3**2+4D0*B0*B2
49305       CQ=C1/3D0-C2**2/9D0
49306       CR=C1*C2/6D0-C0/2D0-C2**3/27D0
49307       CQR=CQ**3+CR**2
49308  
49309 C...Cases with one or three real roots.
49310       IF(CQR.GE.0D0) THEN
49311         S1=(CR+SQRT(CQR))**(1D0/3D0)
49312         S2=(CR-SQRT(CQR))**(1D0/3D0)
49313         U=S1+S2-C2/3D0
49314       ELSE
49315         SABS=SQRT(-CQ)
49316         THE=ACOS(CR/SABS**3)/3D0
49317         SRE=SABS*COS(THE)
49318         U=2D0*SRE-C2/3D0
49319       ENDIF
49320  
49321 C...Find and solve two second-degree equations.
49322       P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
49323       P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
49324       Q1=U/2D0+SQRT(U**2/4D0-B0)
49325       Q2=U/2D0-SQRT(U**2/4D0-B0)
49326       IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
49327         QSAV=Q1
49328         Q1=Q2
49329         Q2=QSAV
49330       ENDIF
49331       X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
49332       X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
49333       X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
49334       X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
49335  
49336 C...Order eigenvalues in asceding mass.
49337       W(1)=X(1)
49338       DO 150 I1=2,4
49339         DO 130 I2=I1-1,1,-1
49340           IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
49341           W(I2+1)=W(I2)
49342   130   CONTINUE
49343   140   W(I2+1)=X(I1)
49344   150 CONTINUE
49345  
49346 C...Find equation system for eigenvectors.
49347       DO 250 I=1,4
49348         DO 170 J1=1,4
49349           D(J1,J1)=A(J1,J1)-W(I)
49350           DO 160 J2=J1+1,4
49351             D(J1,J2)=A(J1,J2)
49352             D(J2,J1)=A(J2,J1)
49353   160     CONTINUE
49354   170   CONTINUE
49355  
49356 C...Find largest element in matrix.
49357         DAMAX=0D0
49358         DO 190 J1=1,4
49359           DO 180 J2=1,4
49360             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
49361             JA=J1
49362             JB=J2
49363             DAMAX=ABS(D(J1,J2))
49364   180     CONTINUE
49365   190   CONTINUE
49366  
49367 C...Subtract others by multiple of row selected above.
49368         DAMAX=0D0
49369         DO 210 J3=JA+1,JA+3
49370           J1=J3-4*((J3-1)/4)
49371           RL=D(J1,JB)/D(JA,JB)
49372           DO 200 J2=1,4
49373             D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
49374             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
49375             JC=J1
49376             JD=J2
49377             DAMAX=ABS(D(J1,J2))
49378   200     CONTINUE
49379   210   CONTINUE
49380  
49381 C...Do one more subtraction of a row.
49382         DAMAX=0D0
49383         DO 230 J3=JC+1,JC+3
49384           J1=J3-4*((J3-1)/4)
49385           IF(J1.EQ.JA) GOTO 230
49386           RL=D(J1,JD)/D(JC,JD)
49387           DO 220 J2=1,4
49388             IF(J2.EQ.JB) GOTO 220
49389             D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
49390             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
49391             JE=J1
49392             DAMAX=ABS(D(J1,J2))
49393   220     CONTINUE
49394   230   CONTINUE
49395  
49396 C...Construct unnormalized eigenvector.
49397         JF1=JD+1-4*(JD/4)
49398         JF2=JD+2-4*((JD+1)/4)
49399         IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
49400         IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
49401         E(JF1)=-D(JE,JF2)
49402         E(JF2)=D(JE,JF1)
49403         E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
49404         E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
49405      &  D(JA,JB)
49406  
49407 C...Normalize and fill in final array.
49408         EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
49409         SGN=(-1D0)**INT(PYR(0)+0.5D0)
49410         DO 240 J=1,4
49411           Z(I,J)=SGN*E(J)/EA
49412   240   CONTINUE
49413   250 CONTINUE
49414  
49415       RETURN
49416       END
49417  
49418 C*********************************************************************
49419  
49420 C...PYHGGM
49421 C...Determines the Higgs boson mass spectrum using several inputs.
49422  
49423       SUBROUTINE PYHGGM(ALPHA)
49424  
49425 C...Double precision and integer declarations.
49426       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49427       IMPLICIT INTEGER(I-N)
49428       INTEGER PYK,PYCHGE,PYCOMP
49429 C...Parameter statement to help give large particle numbers.
49430       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49431      &KEXCIT=4000000,KDIMEN=5000000)
49432 C...Commonblocks.
49433       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49434       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49435       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
49436       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49437       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
49438  
49439 C...Local variables.
49440       DOUBLE PRECISION AT,AB,XMU,TANB
49441       DOUBLE PRECISION ALPHA
49442       INTEGER IHOPT
49443       DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
49444       DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
49445       DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
49446       DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
49447  
49448       IHOPT=IMSS(4)
49449       IF(IHOPT.EQ.2) THEN
49450         ALPHA=RMSS(18)
49451         RETURN
49452       ENDIF
49453       AT=RMSS(16)
49454       AB=RMSS(15)
49455       DMGL=RMSS(3)
49456       XMU=RMSS(4)
49457       TANB=RMSS(5)
49458  
49459       DMA=RMSS(19)
49460       DTANB=TANB
49461       DMQ=RMSS(10)
49462       DMUR=RMSS(12)
49463       DMDR=RMSS(11)
49464       DMTOP=PMAS(6,1)
49465       DMC=PMAS(PYCOMP(KSUSY1+37),1)
49466       DAU=AT
49467       DAD=AB
49468       DMU=XMU
49469       RMSS(40)=0D0
49470       RMSS(41)=0D0
49471  
49472       IF(IHOPT.EQ.0) THEN
49473         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49474      &  DMHCH,DSA,DCA,DTANBA)
49475       ELSEIF(IHOPT.EQ.1) THEN
49476         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49477      &  DMHCH,DSA,DCA,DTANBA)
49478         CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
49479      &  DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
49480      &  DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
49481         RMSS(40)=DDT
49482         RMSS(41)=DDB
49483         DMH=DMHP
49484         DHM=DHMP
49485         DMA=DAMP
49486         IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
49487          WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
49488          WRITE(MSTU(11),*) ' STOP1 MASSES = ',
49489      & PMAS(PYCOMP(1000006),1),DSTOP2
49490         ENDIF
49491         IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
49492          WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
49493          WRITE(MSTU(11),*) ' STOP2 MASSES = ',
49494      & PMAS(PYCOMP(2000006),1),DSTOP1
49495         ENDIF
49496         IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
49497          WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
49498          WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
49499      & PMAS(PYCOMP(1000005),1),DSBOT2
49500         ENDIF
49501         IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
49502          WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
49503          WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
49504      & PMAS(PYCOMP(2000005),1),DSBOT1
49505         ENDIF
49506  
49507       ELSEIF (IHOPT.EQ.3) THEN
49508 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
49509 C...Currently only available for SLHA spectrum read-in.
49510         IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
49511           CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
49512      &         //' spectrum, change IMSS(1) or IMSS(4) option.')
49513         ENDIF
49514         ALPHA=RMSS(18)
49515         RETURN
49516       ENDIF
49517  
49518       ALPHA=ACOS(DCA)
49519  
49520       PMAS(25,1)=DMH
49521       PMAS(35,1)=DHM
49522       PMAS(36,1)=DMA
49523       PMAS(37,1)=DMHCH
49524  
49525       RETURN
49526       END
49527  
49528 C*********************************************************************
49529  
49530 C...PYSUBH
49531 C...This routine computes the renormalization group improved
49532 C...values of Higgs masses and couplings in the MSSM.
49533  
49534 C...Program based on the work by M. Carena, J.R. Espinosa,
49535 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
49536  
49537 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
49538 C...All masses in GeV units. MA is the CP-odd Higgs mass,
49539 C...MTOP is the physical top mass, MQ and MUR are the soft
49540 C...supersymmetry breaking mass parameters of left handed
49541 C...and right handed stops respectively, AU and AD are the
49542 C...stop and sbottom trilinear soft breaking terms,
49543 C...respectively,  and MU is the supersymmetric
49544 C...Higgs mass parameter. We use the  conventions from
49545 C...the physics report of Haber and Kane: left right
49546 C...stop mixing term proportional to (AU - MU/TANB)
49547 C...We use as input TANB defined at the scale MTOP
49548  
49549 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
49550 C...where MH and HM are the lightest and heaviest CP-even
49551 C...Higgs masses, MHCH is the charged Higgs mass and
49552 C...ALPHA is the Higgs mixing angle
49553 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
49554  
49555 C...Range of validity:
49556 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
49557 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
49558 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
49559 C...are the sbottom  mass eigenvalues, respectively. This
49560 C...range automatically excludes the existence of tachyons.
49561 C...For the charged Higgs mass computation, the method is
49562 C...valid if
49563 C...2 * |MB * AD* TANB|  < M_SUSY**2,  2 * |MTOP * AU| < M_SUSY**2
49564 C...2 * |MB * MU * TANB| < M_SUSY**2,  2 * |MTOP * MU| < M_SUSY**2
49565 C...where M_SUSY**2 is the average of the squared stop mass
49566 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
49567 C...masses have been assumed to be of order of the stop ones
49568 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
49569  
49570       SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
49571      &XMHCH,SA,CA,TANBA)
49572  
49573 C...Double precision and integer declarations.
49574       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49575       IMPLICIT INTEGER(I-N)
49576       INTEGER PYK,PYCHGE,PYCOMP
49577 C...Parameter statement to help give large particle numbers.
49578       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49579      &KEXCIT=4000000,KDIMEN=5000000)
49580 C...Commonblocks.
49581       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49582       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49583       COMMON/PYHTRI/HHH(7)
49584       SAVE /PYDAT1/,/PYDAT2/
49585  
49586 C...Local variables.
49587       DOUBLE PRECISION PYALEM,PYALPS
49588       DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
49589       DOUBLE PRECISION XMHCH,SA,CA
49590       DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
49591       DOUBLE PRECISION Q02
49592       DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
49593       DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
49594       DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
49595       DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
49596       DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
49597       DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
49598       DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
49599       DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
49600  
49601       XMZ = PMAS(23,1)
49602       Q02=XMZ**2
49603       AEM=PYALEM(Q02)
49604       ALP1=AEM/(1D0-PARU(102))
49605       ALP2=AEM/PARU(102)
49606       ALPH3Z=PYALPS(Q02)
49607  
49608       ALP1 = 0.0101D0
49609       ALP2 = 0.0337D0
49610       ALPH3Z = 0.12D0
49611  
49612       V = 174.1D0
49613       PI = PARU(1)
49614       TANBA = TANB
49615       TANBT = TANB
49616  
49617 C...MBOTTOM(MTOP) = 3. GEV
49618       XMB = PYMRUN(5,XMTOP**2)
49619       ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
49620      &LOG(XMTOP**2/XMZ**2))
49621  
49622 C...RMTOP= RUNNING TOP QUARK MASS
49623       RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
49624       XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
49625       T = LOG(XMS**2/XMTOP**2)
49626       SINB = TANB/((1D0 + TANB**2)**0.5D0)
49627       COSB = SINB/TANB
49628 C...IF(MA.LE.XMTOP) TANBA = TANBT
49629       IF(XMA.GT.XMTOP)
49630      &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
49631      &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
49632      &LOG(XMA**2/XMTOP**2))
49633  
49634       SINBT = TANBT/SQRT(1D0 + TANBT**2)
49635       COSBT = 1D0/SQRT(1D0 + TANBT**2)
49636 C      COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
49637       G1 = SQRT(ALP1*4D0*PI)
49638       G2 = SQRT(ALP2*4D0*PI)
49639       G3 = SQRT(ALP3*4D0*PI)
49640       HU = RMTOP/V/SINBT
49641       HD =  XMB/V/COSBT
49642       HU2=HU*HU
49643       HD2=HD*HD
49644       HU4=HU2*HU2
49645       HD4=HD2*HD2
49646       AU2=AU**2
49647       AD2=AD**2
49648       XMS2=XMS**2
49649       XMS3=XMS**3
49650       XMS4=XMS2*XMS2
49651       XMU2=XMU*XMU
49652       PI2=PI*PI
49653  
49654       XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
49655       XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
49656       AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
49657      &+ 3D0*(AU + AD)**2/XMS2)/6D0
49658       XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
49659      &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
49660      &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
49661      &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
49662      &-  16D0*G3**2) *T/16D0/PI2)
49663       XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
49664      &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
49665      &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
49666      &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
49667      &-  16D0*G3**2) *T/16D0/PI2)
49668       XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49669      &(HU2 + HD2)*T/16D0/PI2)
49670      &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49671      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49672      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49673      &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
49674      &-  16D0*G3**2) *T/16D0/PI2)
49675      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49676      &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
49677      &-  16D0*G3**2) *T/16D0/PI2)
49678       XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
49679      &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49680      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49681      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49682      &XMS4)*
49683      &(1+ (6D0*HU2 -2D0* HD2
49684      &-  16D0*G3**2) *T/16D0/PI2)
49685      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49686      &XMS4)*
49687      &(1+ (6D0*HD2 -2D0* HU2/2D0
49688      &-  16D0*G3**2) *T/16D0/PI2)
49689       XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
49690      &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
49691      &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
49692      &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
49693       XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
49694      &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49695      &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
49696      &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49697       XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
49698      &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49699      &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
49700      &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49701       HHH(1)=XLAM1
49702       HHH(2)=XLAM2
49703       HHH(3)=XLAM3
49704       HHH(4)=XLAM4
49705       HHH(5)=XLAM5
49706       HHH(6)=XLAM6
49707       HHH(7)=XLAM7
49708       TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
49709      &2D0* XLAM6*SINBT*COSBT
49710      &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
49711      &+ XLAM5*COSBT**2)
49712       DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
49713      &XLAM6*COSBT**2
49714      &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
49715      &2D0* XLAM6* COSBT*SINBT
49716      &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49717      &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
49718      &((XLAM1* COSBT**2 +2D0*
49719      &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
49720      &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
49721      &*SINBT**2
49722      &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
49723      &+ XLAM4) + XLAM6*COSBT**2
49724      &+ XLAM7* SINBT**2))
49725  
49726       XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
49727       XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
49728       XHM = SQRT(XHM2)
49729       XMH = SQRT(XMH2)
49730       XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
49731       XMHCH = SQRT(XMHCH2)
49732  
49733       SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49734      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49735      &XLAM6* COSBT*SINBT
49736      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49737      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49738      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
49739      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
49740  
49741       COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
49742      &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
49743      &XMA**2*SINBT*COSBT))/2D0**0.5D0/
49744      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
49745      &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49746      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49747      &XLAM6* COSBT*SINBT
49748      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49749      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49750      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
49751  
49752       SA = -SINALP
49753       CA = -COSALP
49754  
49755   100 CONTINUE
49756  
49757       RETURN
49758       END
49759  
49760 C*********************************************************************
49761  
49762 C...PYPOLE
49763 C...This subroutine computes the CP-even higgs and CP-odd pole
49764 c...Higgs masses and mixing angles.
49765  
49766 C...Program based on the work by M. Carena, M. Quiros
49767 C...and C.E.M. Wagner, "Effective potential methods and
49768 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
49769  
49770 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
49771 C...AT,AB,MU
49772 C...where MCHI is the largest chargino mass, MA is the running
49773 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
49774 C...expectaion values at the scale MTOP, MQ is the third generation
49775 C...left handed squark mass parameter, MUR is the third generation
49776 C...right handed stop mass parameter, MDR is the third generation
49777 C...right handed sbottom mass parameter, MTOP is the pole top quark
49778 C...mass; AT,AB are the soft supersymmetry breaking trilinear
49779 C...couplings of the stop and sbottoms, respectively, and MU is the
49780 C...supersymmetric mass parameter
49781  
49782 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
49783 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
49784 C...masses are given, what makes the running of the program
49785 c...much faster and it is quite generally a good approximation
49786 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
49787 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
49788 c...and if IHIGGS=3, then h,H,A polarizations are computed
49789  
49790 C...Output: MH and MHP which are the lightest CP-even Higgs running
49791 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
49792 C...Higgs running and pole masses, repectively; SA and CA are the
49793 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
49794 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
49795 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
49796 C...the value of TANB at the CP-odd Higgs mass scale
49797  
49798 C...This subroutine makes use of CERN library subroutine
49799 C...integration package, which makes the computation of the
49800 C...pole Higgs masses somewhat faster. We thank P. Janot for this
49801 C...improvement. Those who are not able to call the CERN
49802 C...libraries, please use the subroutine SUBHPOLE2.F, which
49803 C...although somewhat slower, gives identical results
49804  
49805       SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
49806      &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
49807  
49808 C...Double precision and integer declarations.
49809       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49810       IMPLICIT INTEGER(I-N)
49811  
49812 C...Parameters.
49813       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49814       SAVE /PYDAT1/
49815       INTEGER PYK,PYCHGE,PYCOMP
49816  
49817 C...Local variables.
49818       DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
49819      &SSBOT2(2),B(2,2),COUPB(2,2),
49820      &HCOUPT(2,2),HCOUPB(2,2),
49821      &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
49822  
49823       DELTA(1,1) = 1D0
49824       DELTA(2,2) = 1D0
49825       DELTA(1,2) = 0D0
49826       DELTA(2,1) = 0D0
49827       V = 174.1D0
49828       XMZ=91.18D0
49829       PI=PARU(1)
49830       RXMT=PYMRUN(6,XMT**2)
49831       CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
49832      &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
49833  
49834       SINB = TANB/(TANB**2+1D0)**0.5D0
49835       COSB = 1D0/(TANB**2+1D0)**0.5D0
49836       COS2B = SINB**2 - COSB**2
49837       SINBPA = SINB*CA + COSB*SA
49838       COSBPA = COSB*CA - SINB*SA
49839       RMBOT = PYMRUN(5,XMT**2)
49840       XMQ2 = XMQ**2
49841       XMUR2 = XMUR**2
49842       IF(XMUR.LT.0D0) XMUR2=-XMUR2
49843       XMDR2 = XMDR**2
49844       XMST11 = RXMT**2 + XMQ2  - 0.35D0*XMZ**2*COS2B
49845       XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49846       IF(XMST11.LT.0D0) GOTO 500
49847       IF(XMST22.LT.0D0) GOTO 500
49848       XMSB11 = RMBOT**2 + XMQ2  + 0.42D0*XMZ**2*COS2B
49849       XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49850       IF(XMSB11.LT.0D0) GOTO 500
49851       IF(XMSB22.LT.0D0) GOTO 500
49852 C      WMST11 = RXMT**2 + XMQ2
49853 C      WMST22 = RXMT**2 + XMUR2
49854       XMST12 = RXMT*(AT - XMU/TANB)
49855       XMSB12 = RMBOT*(AB - XMU*TANB)
49856  
49857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49858 C...STOP EIGENVALUES CALCULATION
49859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49860  
49861       STOP12 = 0.5D0*(XMST11+XMST22) +
49862      &0.5D0*((XMST11+XMST22)**2 -
49863      &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49864       STOP22 = 0.5D0*(XMST11+XMST22) -
49865      &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49866      &XMST12**2))**0.5D0
49867  
49868       IF(STOP22.LT.0D0) GOTO 500
49869       SSTOP2(1) = STOP12
49870       SSTOP2(2) = STOP22
49871       STOP1 = STOP12**0.5D0
49872       STOP2 = STOP22**0.5D0
49873 C      STOP1W = STOP1
49874 C      STOP2W = STOP2
49875  
49876       IF(XMST12.EQ.0D0) XST11 = 1D0
49877       IF(XMST12.EQ.0D0) XST12 = 0D0
49878       IF(XMST12.EQ.0D0) XST21 = 0D0
49879       IF(XMST12.EQ.0D0) XST22 = 1D0
49880  
49881       IF(XMST12.EQ.0D0) GOTO 110
49882  
49883   100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49884       XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49885       XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49886       XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49887  
49888   110 T(1,1) = XST11
49889       T(2,2) = XST22
49890       T(1,2) = XST12
49891       T(2,1) = XST21
49892  
49893       SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49894      &0.5D0*((XMSB11+XMSB22)**2 -
49895      &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49896       SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49897      &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49898      &XMSB12**2))**0.5D0
49899       IF(SBOT22.LT.0D0) GOTO 500
49900       SBOT1 = SBOT12**0.5D0
49901       SBOT2 = SBOT22**0.5D0
49902  
49903       SSBOT2(1) = SBOT12
49904       SSBOT2(2) = SBOT22
49905  
49906       IF(XMSB12.EQ.0D0) XSB11 = 1D0
49907       IF(XMSB12.EQ.0D0) XSB12 = 0D0
49908       IF(XMSB12.EQ.0D0) XSB21 = 0D0
49909       IF(XMSB12.EQ.0D0) XSB22 = 1D0
49910  
49911       IF(XMSB12.EQ.0D0) GOTO 130
49912  
49913   120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49914       XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49915       XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49916       XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49917  
49918   130 B(1,1) = XSB11
49919       B(2,2) = XSB22
49920       B(1,2) = XSB12
49921       B(2,1) = XSB21
49922  
49923  
49924       SINT = 0.2320D0
49925       SQR = DSQRT(2D0)
49926       VP = 174.1D0*SQR
49927  
49928 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49929 C...STARTING OF LIGHT HIGGS
49930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49931  
49932       IF(IHIGGS.EQ.0) GOTO 490
49933  
49934       DO 150 I = 1,2
49935         DO 140 J = 1,2
49936           COUPT(I,J) =
49937      &    SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49938      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49939      &    -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49940      &    -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49941      &    T(1,J)*T(2,I))
49942   140   CONTINUE
49943   150 CONTINUE
49944  
49945  
49946       DO 170 I = 1,2
49947         DO 160 J = 1,2
49948           COUPB(I,J) =
49949      &    -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49950      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49951      &    +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49952      &    +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49953      &    B(1,J)*B(2,I))
49954   160   CONTINUE
49955   170 CONTINUE
49956  
49957       PRUN = XMH
49958       EPS = 1D-4*PRUN
49959       ITER = 0
49960   180 ITER = ITER + 1
49961       DO 230  I3 = 1,3
49962  
49963         PR(I3)=PRUN+(I3-2)*EPS/2
49964         P2=PR(I3)**2
49965         POLT = 0D0
49966         DO 200 I = 1,2
49967           DO 190 J = 1,2
49968             POLT = POLT + COUPT(I,J)**2*3D0*
49969      &      PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49970   190     CONTINUE
49971   200   CONTINUE
49972  
49973         POLB = 0D0
49974         DO 220 I = 1,2
49975           DO 210 J = 1,2
49976             POLB = POLB + COUPB(I,J)**2*3D0*
49977      &      PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49978   210     CONTINUE
49979   220   CONTINUE
49980 C        RXMT2 = RXMT**2
49981         XMT2=XMT**2
49982  
49983         POLTT =
49984      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
49985      &  CA**2/SINB**2 *
49986      &  (-2D0*XMT**2+0.5D0*P2)*
49987      &  PYFINT(P2,XMT2,XMT2)
49988  
49989         POL = POLT + POLB + POLTT
49990         POLAR(I3) = P2 - XMH**2 - POL
49991   230 CONTINUE
49992       DERIV = (POLAR(3)-POLAR(1))/EPS
49993       DRUN = - POLAR(2)/DERIV
49994       PRUN = PRUN + DRUN
49995       P2 = PRUN**2
49996       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49997       GOTO 180
49998   240 CONTINUE
49999  
50000       XMHP = DSQRT(P2)
50001  
50002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50003 C...END OF LIGHT HIGGS
50004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50005  
50006   250 IF(IHIGGS.EQ.1) GOTO 490
50007  
50008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50009 C... STARTING OF HEAVY HIGGS
50010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50011  
50012       DO 270 I = 1,2
50013         DO 260 J = 1,2
50014           HCOUPT(I,J) =
50015      &    -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
50016      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
50017      &    -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
50018      &    -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
50019      &    T(1,J)*T(2,I))
50020   260   CONTINUE
50021   270 CONTINUE
50022  
50023       DO 290 I = 1,2
50024         DO 280 J = 1,2
50025           HCOUPB(I,J) =
50026      &    SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
50027      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
50028      &    -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
50029      &    -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
50030      &    B(1,J)*B(2,I))
50031           HCOUPB(I,J)=0D0
50032   280   CONTINUE
50033   290 CONTINUE
50034  
50035       PRUN = HM
50036       EPS = 1D-4*PRUN
50037       ITER = 0
50038   300 ITER = ITER + 1
50039       DO 350 I3 = 1,3
50040         PR(I3)=PRUN+(I3-2)*EPS/2
50041         HP2=PR(I3)**2
50042  
50043         HPOLT = 0D0
50044         DO 320 I = 1,2
50045           DO 310 J = 1,2
50046             HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
50047      &      PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50048   310     CONTINUE
50049   320   CONTINUE
50050  
50051         HPOLB = 0D0
50052         DO 340 I = 1,2
50053           DO 330 J = 1,2
50054             HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
50055      &      PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50056   330     CONTINUE
50057   340   CONTINUE
50058  
50059 C        RXMT2 = RXMT**2
50060         XMT2  = XMT**2
50061  
50062         HPOLTT =
50063      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
50064      &  SA**2/SINB**2 *
50065      &  (-2D0*XMT**2+0.5D0*HP2)*
50066      &  PYFINT(HP2,XMT2,XMT2)
50067  
50068         HPOL = HPOLT + HPOLB + HPOLTT
50069         POLAR(I3) =HP2-HM**2-HPOL
50070   350 CONTINUE
50071       DERIV = (POLAR(3)-POLAR(1))/EPS
50072       DRUN = - POLAR(2)/DERIV
50073       PRUN = PRUN + DRUN
50074       HP2 = PRUN**2
50075       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
50076       GOTO 300
50077   360 CONTINUE
50078  
50079  
50080   370 CONTINUE
50081       HMP = HP2**0.5D0
50082  
50083 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50084 C... END OF HEAVY HIGGS
50085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50086  
50087       IF(IHIGGS.EQ.2) GOTO 490
50088  
50089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50090 C...BEGINNING OF PSEUDOSCALAR HIGGS
50091 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50092  
50093       DO 390 I = 1,2
50094         DO 380 J = 1,2
50095           ACOUPT(I,J) =
50096      &    -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
50097      &    (T(1,I)*T(2,J) -T(1,J)*T(2,I))
50098   380   CONTINUE
50099   390 CONTINUE
50100       DO 410 I = 1,2
50101         DO 400 J = 1,2
50102           ACOUPB(I,J) =
50103      &    RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
50104      &    (B(1,I)*B(2,J) -B(1,J)*B(2,I))
50105   400   CONTINUE
50106   410 CONTINUE
50107  
50108       PRUN = XMA
50109       EPS = 1D-4*PRUN
50110       ITER = 0
50111   420 ITER = ITER + 1
50112       DO 470 I3 = 1,3
50113         PR(I3)=PRUN+(I3-2)*EPS/2
50114         AP2=PR(I3)**2
50115         APOLT = 0D0
50116         DO 440 I = 1,2
50117           DO 430 J = 1,2
50118             APOLT = APOLT + ACOUPT(I,J)**2*3D0*
50119      &      PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50120   430     CONTINUE
50121   440   CONTINUE
50122         APOLB = 0D0
50123         DO 460 I = 1,2
50124           DO 450 J = 1,2
50125             APOLB = APOLB + ACOUPB(I,J)**2*3D0*
50126      &      PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50127   450     CONTINUE
50128   460   CONTINUE
50129 C        RXMT2 = RXMT**2
50130         XMT2=XMT**2
50131         APOLTT =
50132      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
50133      &  COSB**2/SINB**2 *
50134      &  (-0.5D0*AP2)*
50135      &  PYFINT(AP2,XMT2,XMT2)
50136         APOL = APOLT + APOLB + APOLTT
50137         POLAR(I3) = AP2 - XMA**2 -APOL
50138   470 CONTINUE
50139       DERIV = (POLAR(3)-POLAR(1))/EPS
50140       DRUN = - POLAR(2)/DERIV
50141       PRUN = PRUN + DRUN
50142       AP2 = PRUN**2
50143       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
50144       GOTO 420
50145   480 CONTINUE
50146  
50147       AMP = DSQRT(AP2)
50148  
50149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50150 C...END OF PSEUDOSCALAR HIGGS
50151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50152  
50153       IF(IHIGGS.EQ.3) GOTO 490
50154  
50155   490 CONTINUE
50156       RETURN
50157   500 CONTINUE
50158       WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
50159       WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
50160       WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
50161       WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
50162       CALL PYSTOP(107)
50163       END
50164  
50165 C*********************************************************************
50166  
50167 C...PYRGHM
50168 C...Auxiliary to PYPOLE.
50169  
50170       SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
50171      *    MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
50172       IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
50173       DIMENSION VH(2,2),M2(2,2),M2P(2,2)
50174 C...Parameters.
50175       INTEGER MSTU,MSTJ
50176       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50177       SAVE /PYDAT1/
50178  
50179       MZ = 91.18D0
50180       PI = PARU(1)
50181       V  = 174.1D0
50182       ALPHA1 = 0.0101D0
50183       ALPHA2 = 0.0337D0
50184       ALPHA3Z = 0.12D0
50185       TANBA = TANB
50186       TANBT = TANB
50187 C     MBOTTOM(MTOP) = 3. GEV
50188       MB = PYMRUN(5,MTOP**2)
50189       ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
50190      *LOG(MTOP**2/MZ**2))
50191 C     RMTOP= RUNNING TOP QUARK MASS
50192       RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50193       TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
50194       TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
50195       TD = LOG((MD**2 + MTOP**2)/MTOP**2)
50196 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50197 C
50198 C    NEW DEFINITION, TGLU.
50199 C
50200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50201       TGLU = LOG(MGLU**2/MTOP**2)
50202       SINB = TANB/DSQRT(1D0 + TANB**2)
50203       COSB = SINB/TANB
50204       IF(MA.GT.MTOP)
50205      *TANBA = TANB*(1D0-3D0/32D0/PI**2*
50206      *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
50207      *LOG(MA**2/MTOP**2))
50208       IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
50209       SINB = TANBT/SQRT(1D0 + TANBT**2)
50210       COSB = 1D0/DSQRT(1D0 + TANBT**2)
50211       G1 = SQRT(ALPHA1*4D0*PI)
50212       G2 = SQRT(ALPHA2*4D0*PI)
50213       G3 = SQRT(ALPHA3*4D0*PI)
50214       HU = RMTOP/V/SINB
50215       HD =  MB/V/COSB
50216       CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
50217      *SBOT1,SBOT2,DELTAMT,DELTAMB)
50218       IF(MQ.GT.MUR) TP = TQ - TU
50219       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
50220       IF(MQ.GT.MUR) TDP = TU
50221       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
50222       IF(MQ.GT.MD) TPD = TQ - TD
50223       IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
50224       IF(MQ.GT.MD) TDPD = TD
50225       IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
50226  
50227       IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
50228       IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
50229      * HD**2*(G1**2/3D0+G2**2)*TPD
50230  
50231       IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
50232       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
50233      * HU**2*(-G1**2/3D0+G2**2)*TP
50234  
50235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50236 C
50237 C  DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
50238 C  THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
50239 C  AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
50240 C  TWO STOPS.
50241 C
50242 C
50243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50244  
50245       DLAMBDAP2 = 0D0
50246       IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
50247        IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
50248         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
50249        ENDIF
50250  
50251        IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
50252         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50253        ENDIF
50254  
50255        IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
50256         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50257        ENDIF
50258  
50259        IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
50260         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
50261        ENDIF
50262  
50263        IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
50264         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50265        ENDIF
50266  
50267        IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
50268         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50269        ENDIF
50270       ENDIF
50271       DLAMBDA3 = 0D0
50272       DLAMBDA4 = 0D0
50273       IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
50274       IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
50275      *(G2**2-G1**2/3D0)*TPD
50276       IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
50277      *1D0/16D0/PI**2*G1**2*HU**2*TP
50278       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
50279      * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
50280       IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
50281       IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
50282      *HD**2*TPD
50283       LAMBDA1 = ((G1**2 + G2**2)/4D0)*
50284      * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
50285      *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
50286      *+ (3D0*HD**2/2D0 + HU**2/2D0
50287      *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
50288      *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0  + (3D0*HD**2/2D0 + HU**2/2D0
50289      *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
50290       LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
50291      *(TP + TDP)/8D0/PI**2)
50292      *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
50293      *+ (3D0*HU**2/2D0 + HD**2/2D0
50294      *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
50295      *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
50296      *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
50297       LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
50298      *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
50299      *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
50300       LAMBDA4 = (- G2**2/2D0)*(1D0
50301      *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
50302      *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
50303  
50304       LAMBDA5 = 0D0
50305       LAMBDA6 = 0D0
50306       LAMBDA7 = 0D0
50307  
50308       M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
50309      *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
50310  
50311       M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
50312      *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
50313       M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
50314      *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
50315  
50316       M2(2,1) = M2(1,2)
50317 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50318 CCC  THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
50319 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50320  
50321       MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
50322  
50323       IF(MCHI.GT.MSSUSY) GOTO 100
50324       IF(MCHI.LT.MTOP) MCHI=MTOP
50325  
50326       TCHAR=LOG(MSSUSY**2/MCHI**2)
50327  
50328       DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
50329       DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
50330      *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
50331  
50332       DELTAM112=2D0*DELTAL12*V**2*COSB**2
50333       DELTAM222=2D0*DELTAL12*V**2*SINB**2
50334       DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
50335  
50336       M2(1,1)=M2(1,1)+DELTAM112
50337       M2(2,2)=M2(2,2)+DELTAM222
50338       M2(1,2)=M2(1,2)+DELTAM122
50339       M2(2,1)=M2(2,1)+DELTAM122
50340  
50341   100 CONTINUE
50342  
50343 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50344 CCC  END OF CHARGINOS/NEUTRALINOS
50345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50346  
50347       DO 120 I = 1,2
50348         DO 110 J = 1,2
50349           M2P(I,J) = M2(I,J) + VH(I,J)
50350   110   CONTINUE
50351   120 CONTINUE
50352       TRM2P = M2P(1,1) + M2P(2,2)
50353       DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
50354       MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50355       HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50356       HMP = DSQRT(HM2P)
50357       MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
50358       MCH=DSQRT(MCH2)
50359       IF(MH2P.LT.0.) GOTO 130
50360       MHP = SQRT(MH2P)
50361       SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
50362       COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
50363       IF(COS2ALPHA.GE.0.) THEN
50364         ALPHA = ASIN(SIN2ALPHA)/2D0
50365       ELSE
50366         ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
50367       ENDIF
50368       SA = SIN(ALPHA)
50369       CA = COS(ALPHA)
50370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50371 C
50372 C        HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
50373 C        TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
50374 C        HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
50375 C
50376 C
50377 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50378       SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
50379       CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
50380   130 CONTINUE
50381       RETURN
50382       END
50383  
50384 C*********************************************************************
50385  
50386 C...PYGFXX
50387 C...Auxiliary to PYRGHM.
50388  
50389       SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
50390      *  STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
50391       IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
50392       DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
50393 C...Commonblocks.
50394       INTEGER MSTU,MSTJ,KCHG
50395       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50396       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50397       SAVE /PYDAT1/,/PYDAT2/
50398  
50399       G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
50400  
50401       T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
50402      * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
50403  
50404       IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
50405       MQ2 = MQ**2
50406       MUR2 = MUR**2
50407       MD2 = MD**2
50408       TANBA = TANB
50409       SINBA = TANBA/DSQRT(TANBA**2+1D0)
50410       COSBA = SINBA/TANBA
50411  
50412       SINB = TANB/DSQRT(TANB**2+1D0)
50413       COSB = SINB/TANB
50414  
50415       PI = PARU(1)
50416       MZ = PMAS(23,1)
50417       MW = PMAS(24,1)
50418       SW = 1D0-MW**2/MZ**2
50419       V  = 174.1D0
50420  
50421       ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
50422       G2 = DSQRT(0.0336D0*4D0*PI)
50423       G1 = DSQRT(0.0101D0*4D0*PI)
50424  
50425       IF(MQ.GT.MUR) MST = MQ
50426       IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
50427  
50428       MSUSYT = DSQRT(MST**2  + MTOP**2)
50429  
50430       IF(MQ.GT.MD) MSB = MQ
50431       IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
50432  
50433       MB = PYMRUN(5,MSB**2)
50434       MSUSYB = DSQRT(MSB**2 + MB**2)
50435       TT = LOG(MSUSYT**2/MTOP**2)
50436       TB = LOG(MSUSYB**2/MTOP**2)
50437  
50438       RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50439       HT = RMTOP/(V*SINB)
50440       HTST = RMTOP/V
50441       HB = MB/V/COSB
50442       G32 = ALPHA3*4D0*PI
50443       BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
50444       BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
50445       AL2 = 3D0/8D0/PI**2*HT**2
50446 C      BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
50447 C      ALST = 3./8./PI**2*HTST**2
50448       AL1 = 3D0/8D0/PI**2*HB**2
50449  
50450       AL(1,1) = AL1
50451       AL(1,2) = (AL2+AL1)/2D0
50452       AL(2,1) = (AL2+AL1)/2D0
50453       AL(2,2) = AL2
50454  
50455       IF(MA.GT.MTOP) THEN
50456         VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
50457      *        LOG(MTOP**2/MA**2))
50458         H1I = VI* COSBA
50459         H2I = VI*SINBA
50460         H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
50461         H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
50462         H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
50463         H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
50464       ELSE
50465         VI = V
50466         H1I = VI*COSB
50467         H2I = VI*SINB
50468         H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50469         H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50470         H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50471         H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50472       ENDIF
50473  
50474       TANBST = H2T/H1T
50475       SINBT = TANBST/DSQRT(1D0+TANBST**2)
50476  
50477       TANBSB = H2B/H1B
50478       SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
50479       COSBB = SINBB/TANBSB
50480  
50481       DELTAMT = 0D0
50482       DELTAMB = 0D0
50483  
50484       MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50485       MTOP2 = DSQRT(MTOP4)
50486       MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50487      * /(1D0+DELTAMB)**4
50488       MBOT2 = DSQRT(MBOT4)
50489  
50490       STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50491      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50492      *  +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50493      *  MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50494       STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50495      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50496      *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50497      *  MQ2 - MUR2)**2*0.25D0
50498      *  + MTOP2*(AT-XMU/TANBST)**2)
50499       IF(STOP22.LT.0.) GOTO 120
50500       SBOT12 = (MQ2 + MD2)*.5D0
50501      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50502      *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50503      *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50504       SBOT22 = (MQ2 + MD2)*.5D0
50505      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50506      *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50507      *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50508       IF(SBOT22.LT.0.) SBOT22 = 10000D0
50509  
50510       STOP1 = DSQRT(STOP12)
50511       STOP2 = DSQRT(STOP22)
50512       SBOT1 = DSQRT(SBOT12)
50513       SBOT2 = DSQRT(SBOT22)
50514  
50515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50516 C
50517 C     HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
50518 C     ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
50519 C     MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
50520 C     INDUCED CORRECTIONS.
50521 C
50522 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50523  
50524       X=SBOT1
50525       Y=SBOT2
50526       Z=XMGL
50527       IF(X.EQ.Y) X = X - 0.00001D0
50528       IF(X.EQ.Z) X = X - 0.00002D0
50529       IF(Y.EQ.Z) Y = Y - 0.00003D0
50530  
50531       T1=T(X,Y,Z)
50532       X=STOP1
50533       Y=STOP2
50534       Z=XMU
50535       IF(X.EQ.Y) X = X - 0.00001D0
50536       IF(X.EQ.Z) X = X - 0.00002D0
50537       IF(Y.EQ.Z) Y = Y - 0.00003D0
50538       T2=T(X,Y,Z)
50539       DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
50540      *  + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
50541       X=STOP1
50542       Y=STOP2
50543       Z=XMGL
50544       IF(X.EQ.Y) X = X - 0.00001D0
50545       IF(X.EQ.Z) X = X - 0.00002D0
50546       IF(Y.EQ.Z) Y = Y - 0.00003D0
50547       T3=T(X,Y,Z)
50548       DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
50549  
50550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50551 C
50552 C   HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
50553 C   THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
50554 C   POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
50555 C   INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
50556 C   THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
50557 C   TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
50558 C   S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
50559 C   D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
50560 C   QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
50561 C   FORMULATION.  THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
50562 C   CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
50563 C
50564 C
50565 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50566  
50567       MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50568       MTOP2 = DSQRT(MTOP4)
50569       MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50570      * /(1D0+DELTAMB)**4
50571       MBOT2 = DSQRT(MBOT4)
50572  
50573       STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50574      *   +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50575      *   +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50576      *   MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50577       STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50578      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50579      *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50580      *  MQ2 - MUR2)**2*0.25D0
50581      *  + MTOP2*(AT-XMU/TANBST)**2)
50582  
50583       IF(STOP22.LT.0.) GOTO 120
50584       SBOT12 = (MQ2 + MD2)*.5D0
50585      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50586      *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50587      *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50588       SBOT22 = (MQ2 + MD2)*.5D0
50589      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50590      *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50591      *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50592       IF(SBOT22.LT.0.) GOTO 120
50593  
50594  
50595       STOP1 = DSQRT(STOP12)
50596       STOP2 = DSQRT(STOP22)
50597       SBOT1 = DSQRT(SBOT12)
50598       SBOT2 = DSQRT(SBOT22)
50599  
50600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50601 CCC   D-TERMS
50602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50603       STW=SW
50604  
50605       F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
50606      *         LOG(STOP1/STOP2)
50607      *        +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
50608      *        + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
50609  
50610       F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
50611      *        LOG(SBOT1/SBOT2)
50612      *        +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
50613      *        - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
50614  
50615       F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
50616      *         (-.5D0*LOG(STOP12/STOP22)
50617      *        +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
50618      *         G(STOP12,STOP22))
50619  
50620       F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
50621      *         (.5D0*LOG(SBOT12/SBOT22)
50622      *        +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
50623      *        G(SBOT12,SBOT22))
50624  
50625       VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
50626      *  (MQ2+MBOT2)/(MD2+MBOT2))
50627      *  + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
50628      *  LOG(SBOT1**2/SBOT2**2)) +
50629      *  MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
50630      *  (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
50631  
50632       VH3T(1,1) =
50633      *  MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
50634      * -STOP2**2))**2*G(STOP12,STOP22)
50635  
50636       VH3B(1,1)=VH3B(1,1)+
50637      *    MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
50638  
50639       VH3T(1,1) = VH3T(1,1) +
50640      *  MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
50641  
50642       VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
50643      *  (MQ2+MTOP2)/(MUR2+MTOP2))
50644      *  + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
50645      *  LOG(STOP1**2/STOP2**2)) +
50646      *  MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
50647      *  (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
50648  
50649       VH3B(2,2) =
50650      *  MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
50651      * -SBOT2**2))**2*G(SBOT12,SBOT22)
50652  
50653       VH3T(2,2)=VH3T(2,2)+
50654      *    MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
50655       VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
50656       VH3T(1,2) = -
50657      *   MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
50658      * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
50659      * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
50660  
50661       VH3B(1,2) =
50662      * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
50663      * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
50664      * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
50665  
50666  
50667       VH3T(1,2)=VH3T(1,2) +
50668      *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
50669  
50670       VH3B(1,2)=VH3B(1,2) +
50671      *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
50672  
50673       VH3T(2,1) = VH3T(1,2)
50674       VH3B(2,1) = VH3B(1,2)
50675  
50676 C      TQ = LOG((MQ2 + MTOP2)/MTOP2)
50677 C      TU = LOG((MUR2+MTOP2)/MTOP2)
50678 C      TQD = LOG((MQ2 + MB**2)/MB**2)
50679 C      TD = LOG((MD2+MB**2)/MB**2)
50680  
50681       DO 110 I = 1,2
50682         DO 100 J = 1,2
50683           VH(I,J) =
50684      *   6D0/(8D0*PI**2*(H1T**2+H2T**2))
50685      *   *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
50686      *   6D0/(8D0*PI**2*(H1B**2+H2B**2))
50687      *   *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
50688   100   CONTINUE
50689   110 CONTINUE
50690  
50691       GOTO 150
50692   120 DO 140 I =1,2
50693         DO 130 J = 1,2
50694           VH(I,J) = -1D15
50695   130   CONTINUE
50696   140 CONTINUE
50697  
50698  
50699   150 RETURN
50700       END
50701  
50702  
50703  
50704  
50705  
50706 C*********************************************************************
50707  
50708 C...PYFINT
50709 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
50710  
50711       FUNCTION PYFINT(A,B,C)
50712  
50713 C...Double precision and integer declarations.
50714       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50715       IMPLICIT INTEGER(I-N)
50716       INTEGER PYK,PYCHGE,PYCOMP
50717 C...Commonblock.
50718       COMMON/PYINTS/XXM(20)
50719       SAVE/PYINTS/
50720  
50721 C...Local variables.
50722       EXTERNAL PYFISB
50723       DOUBLE PRECISION PYFISB
50724  
50725       XXM(1)=A
50726       XXM(2)=B
50727       XXM(3)=C
50728       XLO=0D0
50729       XHI=1D0
50730       PYFINT  = PYGAUS(PYFISB,XLO,XHI,1D-3)
50731  
50732       RETURN
50733       END
50734  
50735 C*********************************************************************
50736  
50737 C...PYFISB
50738 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
50739  
50740       FUNCTION PYFISB(X)
50741  
50742 C...Double precision and integer declarations.
50743       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50744       IMPLICIT INTEGER(I-N)
50745       INTEGER PYK,PYCHGE,PYCOMP
50746 C...Commonblock.
50747       COMMON/PYINTS/XXM(20)
50748       SAVE/PYINTS/
50749  
50750       PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
50751      &(X*(XXM(2)-XXM(3))+XXM(3)))
50752  
50753       RETURN
50754       END
50755  
50756 C*********************************************************************
50757  
50758 C...PYSFDC
50759 C...Calculates decays of sfermions.
50760  
50761       SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
50762  
50763 C...Double precision and integer declarations.
50764       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50765       IMPLICIT INTEGER(I-N)
50766       INTEGER PYK,PYCHGE,PYCOMP
50767 C...Parameter statement to help give large particle numbers.
50768       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50769      &KEXCIT=4000000,KDIMEN=5000000)
50770 C...Commonblocks.
50771       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50772       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50773       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50774       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50775      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50776       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50777  
50778 C...Local variables.
50779       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
50780       COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
50781       INTEGER KFIN,KCIN
50782       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
50783       DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50784       DOUBLE PRECISION PYLAMF,XL
50785       DOUBLE PRECISION TANW,XW,AEM,C1,AS
50786       DOUBLE PRECISION AL,AR,BL,BR
50787       DOUBLE PRECISION CH1,CH2,CH3,CH4
50788       DOUBLE PRECISION XMBOT,XMTOP
50789       DOUBLE PRECISION XLAM(0:400)
50790       INTEGER IDLAM(400,3)
50791       INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
50792       DOUBLE PRECISION SR2
50793       DOUBLE PRECISION CBETA,SBETA
50794       DOUBLE PRECISION CW
50795       DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
50796       DOUBLE PRECISION COSA,SINA,TANB
50797       DOUBLE PRECISION PYALEM,PI,PYALPS,EI
50798       DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
50799       INTEGER IG,KF1,KF2
50800       INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
50801       DATA IGG/23,25,35,36/
50802       DATA PI/3.141592654D0/
50803       DATA SR2/1.4142136D0/
50804       DATA KFNCHI/1000022,1000023,1000025,1000035/
50805       DATA KFCCHI/1000024,1000037/
50806  
50807 C...COUNT THE NUMBER OF DECAY MODES
50808       LKNT=0
50809  
50810 C...NO NU_R DECAYS
50811       IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
50812      &KFIN.EQ.KSUSY2+16) RETURN
50813  
50814       XMW=PMAS(24,1)
50815       XMW2=XMW**2
50816       XMZ=PMAS(23,1)
50817       XW=PARU(102)
50818       TANW = SQRT(XW/(1D0-XW))
50819       CW=SQRT(1D0-XW)
50820  
50821       DO 110 I=1,4
50822         DO 100 J=1,4
50823           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50824   100   CONTINUE
50825   110 CONTINUE
50826       DO 130 I=1,2
50827         DO 120 J=1,2
50828            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50829            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50830   120   CONTINUE
50831   130 CONTINUE
50832  
50833 C...KCIN
50834       KCIN=PYCOMP(KFIN)
50835 C...ILR is 1 for left and 2 for right.
50836       ILR=KFIN/KSUSY1
50837 C...IFL is matching non-SUSY flavour.
50838       IFL=MOD(KFIN,KSUSY1)
50839 C...IDU is weak isospin, 1 for down and 2 for up.
50840       IDU=2-MOD(IFL,2)
50841  
50842       XMI=PMAS(KCIN,1)
50843       XMI2=XMI**2
50844       AEM=PYALEM(XMI2)
50845       AS =PYALPS(XMI2)
50846       C1=AEM/XW
50847       XMI3=XMI**3
50848       EI=KCHG(IFL,1)/3D0
50849  
50850       XMBOT=PYMRUN(5,XMI2)
50851       XMTOP=PYMRUN(6,XMI2)
50852  
50853       TANB=RMSS(5)
50854       BETA=ATAN(TANB)
50855       ALFA=RMSS(18)
50856       CBETA=COS(BETA)
50857       SBETA=TANB*CBETA
50858       SINA=SIN(ALFA)
50859       COSA=COS(ALFA)
50860       XMU=-RMSS(4)
50861       ATRIT=RMSS(16)
50862       ATRIB=RMSS(15)
50863       ATRIL=RMSS(17)
50864  
50865 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50866  
50867       IF(IMSS(11).EQ.1) THEN
50868         XMP=RMSS(29)
50869         IDG=39+KSUSY1
50870         XMGR=PMAS(PYCOMP(IDG),1)
50871         XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50872         IF(IFL.EQ.5) THEN
50873           XMF=XMBOT
50874         ELSEIF(IFL.EQ.6) THEN
50875           XMF=XMTOP
50876         ELSE
50877           XMF=PMAS(IFL,1)
50878         ENDIF
50879         IF(XMI.GT.XMGR+XMF) THEN
50880           LKNT=LKNT+1
50881           IDLAM(LKNT,1)=IDG
50882           IDLAM(LKNT,2)=IFL
50883           IDLAM(LKNT,3)=0
50884           XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50885         ENDIF
50886       ENDIF
50887  
50888 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50889  
50890 C...CHARGED DECAYS:
50891       DO 140 IX=1,2
50892 C...DI -> U CHI1-,CHI2-
50893         IF(IDU.EQ.1) THEN
50894           XMFP=PMAS(IFL+1,1)
50895           XMF =PMAS(IFL,1)
50896 C...UI -> D CHI1+,CHI2+
50897         ELSE
50898           XMFP=PMAS(IFL-1,1)
50899           XMF =PMAS(IFL,1)
50900         ENDIF
50901         XMJ=SMW(IX)
50902         AXMJ=ABS(XMJ)
50903         IF(XMI.GE.AXMJ+XMFP) THEN
50904           XMA2=XMJ**2
50905           XMB2=XMFP**2
50906           IF(IDU.EQ.2) THEN
50907             IF(IFL.EQ.6) THEN
50908               XMFP=XMBOT
50909               XMF =XMTOP
50910             ELSEIF(IFL.LT.6) THEN
50911               XMF=0D0
50912               XMFP=0D0
50913             ENDIF
50914             CBL=VMIXC(IX,1)
50915             CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50916             CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50917             CAR=0D0
50918           ELSE
50919             IF(IFL.EQ.5) THEN
50920               XMF =XMBOT
50921               XMFP=XMTOP
50922             ELSEIF(IFL.LT.5) THEN
50923               XMF=0D0
50924               XMFP=0D0
50925             ENDIF
50926             CBL=UMIXC(IX,1)
50927             CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50928             CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50929             CAR=0D0
50930           ENDIF
50931  
50932           CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50933           CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50934           CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50935           CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50936           CAL=CALP
50937           CBL=CBLP
50938           CAR=CARP
50939           CBR=CBRP
50940  
50941 C...F1 -> F` CHI
50942           IF(ILR.EQ.1) THEN
50943             CA=CAL
50944             CB=CBL
50945 C...F2 -> F` CHI
50946           ELSE
50947             CA=CAR
50948             CB=CBR
50949           ENDIF
50950           LKNT=LKNT+1
50951           XL=PYLAMF(XMI2,XMA2,XMB2)
50952 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50953           XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50954      &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50955           IDLAM(LKNT,3)=0
50956           IF(IDU.EQ.1) THEN
50957             IDLAM(LKNT,1)=-KFCCHI(IX)
50958             IDLAM(LKNT,2)=IFL+1
50959           ELSE
50960             IDLAM(LKNT,1)=KFCCHI(IX)
50961             IDLAM(LKNT,2)=IFL-1
50962           ENDIF
50963         ENDIF
50964   140 CONTINUE
50965  
50966 C...NEUTRAL DECAYS
50967       DO 150 IX=1,4
50968 C...DI -> D CHI10
50969         XMF=PMAS(IFL,1)
50970         XMJ=SMZ(IX)
50971         AXMJ=ABS(XMJ)
50972         IF(XMI.GE.AXMJ+XMF) THEN
50973           XMA2=XMJ**2
50974           XMB2=XMF**2
50975           IF(IDU.EQ.1) THEN
50976             IF(IFL.EQ.5) THEN
50977               XMF=XMBOT
50978             ELSEIF(IFL.LT.5) THEN
50979               XMF=0D0
50980             ENDIF
50981             CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50982             CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50983             CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50984             CBR=CAL
50985           ELSE
50986             IF(IFL.EQ.6) THEN
50987               XMF=XMTOP
50988             ELSEIF(IFL.LT.5) THEN
50989               XMF=0D0
50990             ENDIF
50991             CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50992             CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50993             CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50994             CBR=CAL
50995           ENDIF
50996  
50997           CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50998           CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50999           CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
51000           CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
51001           CAL=CALP
51002           CBL=CBLP
51003           CAR=CARP
51004           CBR=CBRP
51005  
51006 C...F1 -> F CHI
51007           IF(ILR.EQ.1) THEN
51008             CA=CAL
51009             CB=CBL
51010 C...F2 -> F CHI
51011           ELSE
51012             CA=CAR
51013             CB=CBR
51014           ENDIF
51015           LKNT=LKNT+1
51016           XL=PYLAMF(XMI2,XMA2,XMB2)
51017 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
51018           XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
51019      &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
51020           IDLAM(LKNT,1)=KFNCHI(IX)
51021           IDLAM(LKNT,2)=IFL
51022           IDLAM(LKNT,3)=0
51023         ENDIF
51024   150 CONTINUE
51025  
51026 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
51027 C...IG=23,25,35,36
51028       DO 160 II=1,4
51029         IG=IGG(II)
51030         IF(ILR.EQ.1) GOTO 160
51031         XMB=PMAS(IG,1)
51032         XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
51033         IF(XMI.LT.XMSF1+XMB) GOTO 160
51034         IF(IG.EQ.23) THEN
51035           BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
51036           BR=EI*XW/CW
51037           BLR=0D0
51038         ELSEIF(IG.EQ.25) THEN
51039           IF(IFL.EQ.5) THEN
51040             XMF=XMBOT
51041           ELSEIF(IFL.EQ.6) THEN
51042             XMF=XMTOP
51043           ELSEIF(IFL.LT.5) THEN
51044             XMF=0D0
51045           ELSE
51046             XMF=PMAS(IFL,1)
51047           ENDIF
51048           IF(IDU.EQ.2) THEN
51049             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51050      &      XMF**2/XMW*COSA/SBETA
51051             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51052      &      XMF**2/XMW*COSA/SBETA
51053           ELSE
51054             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51055      &      XMF**2/XMW*(-SINA)/CBETA
51056             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51057      &      XMF**2/XMW*(-SINA)/CBETA
51058           ENDIF
51059           IF(IFL.EQ.5) THEN
51060             AT=ATRIB
51061           ELSEIF(IFL.EQ.6) THEN
51062             AT=ATRIT
51063           ELSEIF(IFL.EQ.15) THEN
51064             AT=ATRIL
51065           ELSE
51066             AT=0D0
51067           ENDIF
51068 C.........need to complexify
51069           IF(IDU.EQ.2) THEN
51070             GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
51071      &      AT*COSA)
51072           ELSE
51073             GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
51074      &      AT*SINA)
51075           ENDIF
51076           BL=GHLL
51077           BR=GHRR
51078           BLR=-GHLR
51079         ELSEIF(IG.EQ.35) THEN
51080           IF(IFL.EQ.5) THEN
51081             XMF=XMBOT
51082           ELSEIF(IFL.EQ.6) THEN
51083             XMF=XMTOP
51084           ELSEIF(IFL.LT.5) THEN
51085             XMF=0D0
51086           ELSE
51087             XMF=PMAS(IFL,1)
51088           ENDIF
51089           IF(IDU.EQ.2) THEN
51090             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51091      &      XMF**2/XMW*SINA/SBETA
51092             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51093      &      XMF**2/XMW*SINA/SBETA
51094           ELSE
51095             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51096      &      XMF**2/XMW*COSA/CBETA
51097             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51098      &      XMF**2/XMW*COSA/CBETA
51099           ENDIF
51100           IF(IFL.EQ.5) THEN
51101             AT=ATRIB
51102           ELSEIF(IFL.EQ.6) THEN
51103             AT=ATRIT
51104           ELSEIF(IFL.EQ.15) THEN
51105             AT=ATRIL
51106           ELSE
51107             AT=0D0
51108           ENDIF
51109 C.........Need to complexify
51110           IF(IDU.EQ.2) THEN
51111             GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
51112      &      AT*SINA)
51113           ELSE
51114             GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
51115      &      AT*COSA)
51116           ENDIF
51117           BL=GHLL
51118           BR=GHRR
51119           BLR=GHLR
51120         ELSEIF(IG.EQ.36) THEN
51121           GHLL=0D0
51122           GHRR=0D0
51123           IF(IFL.EQ.5) THEN
51124             XMF=XMBOT
51125           ELSEIF(IFL.EQ.6) THEN
51126             XMF=XMTOP
51127           ELSEIF(IFL.LT.5) THEN
51128             XMF=0D0
51129           ELSE
51130             XMF=PMAS(IFL,1)
51131           ENDIF
51132           IF(IFL.EQ.5) THEN
51133             AT=ATRIB
51134           ELSEIF(IFL.EQ.6) THEN
51135             AT=ATRIT
51136           ELSEIF(IFL.EQ.15) THEN
51137             AT=ATRIL
51138           ELSE
51139             AT=0D0
51140           ENDIF
51141 C.........Need to complexify
51142           IF(IDU.EQ.2) THEN
51143             GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
51144           ELSE
51145             GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
51146           ENDIF
51147           BL=GHLL
51148           BR=GHRR
51149           BLR=GHLR
51150         ENDIF
51151         AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
51152      &  SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
51153      &  (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
51154         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51155         LKNT=LKNT+1
51156         IF(IG.EQ.23) THEN
51157           XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51158         ELSE
51159           XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
51160         ENDIF
51161         IDLAM(LKNT,3)=0
51162         IDLAM(LKNT,1)=KFIN-KSUSY1
51163         IDLAM(LKNT,2)=IG
51164   160 CONTINUE
51165  
51166 C...SF -> SF' + W
51167       XMB=PMAS(24,1)
51168       IF(MOD(IFL,2).EQ.0) THEN
51169         KF1=KSUSY1+IFL-1
51170       ELSE
51171         KF1=KSUSY1+IFL+1
51172       ENDIF
51173       KF2=KF1+KSUSY1
51174       XMSF1=PMAS(PYCOMP(KF1),1)
51175       XMSF2=PMAS(PYCOMP(KF2),1)
51176       IF(XMI.GT.XMB+XMSF1) THEN
51177         IF(MOD(IFL,2).EQ.0) THEN
51178           IF(ILR.EQ.1) THEN
51179             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
51180           ELSE
51181             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
51182           ENDIF
51183         ELSE
51184           IF(ILR.EQ.1) THEN
51185             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
51186           ELSE
51187             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
51188           ENDIF
51189         ENDIF
51190         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51191         LKNT=LKNT+1
51192         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51193         IDLAM(LKNT,3)=0
51194         IDLAM(LKNT,1)=KF1
51195         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51196       ENDIF
51197       IF(XMI.GT.XMB+XMSF2) THEN
51198         IF(MOD(IFL,2).EQ.0) THEN
51199           IF(ILR.EQ.1) THEN
51200             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
51201           ELSE
51202             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
51203           ENDIF
51204         ELSE
51205           IF(ILR.EQ.1) THEN
51206             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
51207           ELSE
51208             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
51209           ENDIF
51210         ENDIF
51211         XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
51212         LKNT=LKNT+1
51213         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51214         IDLAM(LKNT,3)=0
51215         IDLAM(LKNT,1)=KF2
51216         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51217       ENDIF
51218  
51219 C...SF -> SF' + HC
51220       XMB=PMAS(37,1)
51221       IF(MOD(IFL,2).EQ.0) THEN
51222         KF1=KSUSY1+IFL-1
51223       ELSE
51224         KF1=KSUSY1+IFL+1
51225       ENDIF
51226       KF2=KF1+KSUSY1
51227       XMSF1=PMAS(PYCOMP(KF1),1)
51228       XMSF2=PMAS(PYCOMP(KF2),1)
51229       IF(XMI.GT.XMB+XMSF1) THEN
51230         XMF=0D0
51231         XMFP=0D0
51232         AT=0D0
51233         AB=0D0
51234         IF(MOD(IFL,2).EQ.0) THEN
51235 C...T1-> B1 HC
51236           IF(ILR.EQ.1) THEN
51237             CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
51238             CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
51239             CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
51240             CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
51241 C...T2-> B1 HC
51242           ELSE
51243             CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
51244             CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
51245             CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
51246             CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
51247           ENDIF
51248           IF(IFL.EQ.6) THEN
51249             XMF=XMTOP
51250             XMFP=XMBOT
51251             AT=ATRIT
51252             AB=ATRIB
51253           ENDIF
51254         ELSE
51255 C...B1 -> T1 HC
51256           IF(ILR.EQ.1) THEN
51257             CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
51258             CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
51259             CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
51260             CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
51261 C...B2-> T1 HC
51262           ELSE
51263             CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
51264             CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
51265             CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
51266             CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
51267           ENDIF
51268           IF(IFL.EQ.5) THEN
51269             XMF=XMTOP
51270             XMFP=XMBOT
51271             AT=ATRIT
51272             AB=ATRIB
51273           ENDIF
51274         ENDIF
51275         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51276         LKNT=LKNT+1
51277 C.......Need to complexify
51278         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51279      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51280      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51281         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51282         IDLAM(LKNT,3)=0
51283         IDLAM(LKNT,1)=KF1
51284         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51285       ENDIF
51286       IF(XMI.GT.XMB+XMSF2) THEN
51287         XMF=0D0
51288         XMFP=0D0
51289         AT=0D0
51290         AB=0D0
51291         IF(MOD(IFL,2).EQ.0) THEN
51292 C...T1-> B2 HC
51293           IF(ILR.EQ.1) THEN
51294             CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
51295             CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
51296             CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
51297             CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
51298 C...T2-> B2 HC
51299           ELSE
51300             CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
51301             CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
51302             CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
51303             CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
51304           ENDIF
51305           IF(IFL.EQ.6) THEN
51306             XMF=XMTOP
51307             XMFP=XMBOT
51308             AT=ATRIT
51309             AB=ATRIB
51310           ENDIF
51311         ELSE
51312 C...B1 -> T2 HC
51313           IF(ILR.EQ.1) THEN
51314             CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
51315             CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
51316             CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
51317             CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
51318 C...B2-> T2 HC
51319           ELSE
51320             CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
51321             CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
51322             CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
51323             CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
51324           ENDIF
51325           IF(IFL.EQ.5) THEN
51326             XMF=XMTOP
51327             XMFP=XMBOT
51328             AT=ATRIT
51329             AB=ATRIB
51330           ENDIF
51331         ENDIF
51332         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51333         LKNT=LKNT+1
51334 C.......Need to complexify
51335         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51336      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51337      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51338         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51339         IDLAM(LKNT,3)=0
51340         IDLAM(LKNT,1)=KF2
51341         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51342       ENDIF
51343  
51344 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
51345  
51346       IF(IFL.LE.6) THEN
51347         XMFP=0D0
51348         XMF=0D0
51349         IF(IFL.EQ.6) XMF=PMAS(6,1)
51350         IF(IFL.EQ.5) XMF=PMAS(5,1)
51351         XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51352         AXMJ=ABS(XMJ)
51353         IF(XMI.GE.AXMJ+XMF) THEN
51354           AL=-SFMIX(IFL,3)
51355           BL=SFMIX(IFL,1)
51356           AR=-SFMIX(IFL,4)
51357           BR=SFMIX(IFL,2)
51358 C...F1 -> F CHI
51359           IF(ILR.EQ.1) THEN
51360             XCA=AL
51361             XCB=BL
51362 C...F2 -> F CHI
51363           ELSE
51364             XCA=AR
51365             XCB=BR
51366           ENDIF
51367           LKNT=LKNT+1
51368           XMA2=XMJ**2
51369           XMB2=XMF**2
51370           XL=PYLAMF(XMI2,XMA2,XMB2)
51371           XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
51372      &    (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
51373           IDLAM(LKNT,1)=KSUSY1+21
51374           IDLAM(LKNT,2)=IFL
51375           IDLAM(LKNT,3)=0
51376         ENDIF
51377       ENDIF
51378  
51379 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
51380       IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
51381      &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
51382 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
51383 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
51384 C...M*M = C1**2 * G**2/(16PI**2)
51385 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
51386         LKNT=LKNT+1
51387         XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
51388         XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
51389         IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
51390         IDLAM(LKNT,1)=KSUSY1+22
51391         IDLAM(LKNT,2)=4
51392         IDLAM(LKNT,3)=0
51393       ENDIF
51394  
51395 C...R-violating sfermion decays (SKANDS).
51396       CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
51397  
51398       IKNT=LKNT
51399       XLAM(0)=0D0
51400       DO 170 I=1,IKNT
51401         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51402         XLAM(0)=XLAM(0)+XLAM(I)
51403   170 CONTINUE
51404       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
51405  
51406       RETURN
51407       END
51408  
51409 C*********************************************************************
51410  
51411 C...PYGLUI
51412 C...Calculates gluino decay modes.
51413  
51414       SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
51415  
51416 C...Double precision and integer declarations.
51417       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51418       IMPLICIT INTEGER(I-N)
51419       INTEGER PYK,PYCHGE,PYCOMP
51420 C...Parameter statement to help give large particle numbers.
51421       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51422      &KEXCIT=4000000,KDIMEN=5000000)
51423 C...Commonblocks.
51424       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51425       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51426       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51427       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51428      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51429 CC     &SFMIX(16,4),
51430 C      COMMON/PYINTS/XXM(20)
51431       COMPLEX*16 CXC
51432       COMMON/PYINTC/XXC(10),CXC(8)
51433       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51434  
51435 C...Local variables
51436       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51437       DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
51438       DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
51439       DOUBLE PRECISION PYLAMF,XL
51440       DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
51441       DOUBLE PRECISION CA,CB,AL,AR,BL,BR
51442       DOUBLE PRECISION XLAM(0:400)
51443       INTEGER IDLAM(400,3)
51444       INTEGER LKNT,IX,ILR,I,IKNT,IFL
51445       DOUBLE PRECISION SR2
51446       DOUBLE PRECISION GAM
51447       DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
51448       EXTERNAL PYGAUS,PYXXZ6
51449       DOUBLE PRECISION PYGAUS,PYXXZ6
51450       DOUBLE PRECISION PREC
51451       INTEGER KFNCHI(4),KFCCHI(2)
51452       DATA PI/3.141592654D0/
51453       DATA SR2/1.4142136D0/
51454       DATA PREC/1D-2/
51455       DATA KFNCHI/1000022,1000023,1000025,1000035/
51456       DATA KFCCHI/1000024,1000037/
51457  
51458 C...COUNT THE NUMBER OF DECAY MODES
51459       LKNT=0
51460       IF(KFIN.NE.KSUSY1+21) RETURN
51461       KCIN=PYCOMP(KFIN)
51462  
51463       XW=PARU(102)
51464       TANW = SQRT(XW/(1D0-XW))
51465  
51466       XMI=PMAS(KCIN,1)
51467       AXMI=ABS(XMI)
51468       XMI2=XMI**2
51469       AEM=PYALEM(XMI2)
51470       AS =PYALPS(XMI2)
51471       C1=AEM/XW
51472       XMI3=AXMI**3
51473  
51474       XMI=SIGN(XMI,RMSS(3))
51475  
51476 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
51477  
51478       IF(IMSS(11).EQ.1) THEN
51479         XMP=RMSS(29)
51480         IDG=39+KSUSY1
51481         XMGR=PMAS(PYCOMP(IDG),1)
51482         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51483         IF(AXMI.GT.XMGR) THEN
51484           LKNT=LKNT+1
51485           IDLAM(LKNT,1)=IDG
51486           IDLAM(LKNT,2)=21
51487           IDLAM(LKNT,3)=0
51488           XLAM(LKNT)=XFAC
51489         ENDIF
51490       ENDIF
51491  
51492 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
51493  
51494       DO 110 IFL=1,6
51495         DO 100 ILR=1,2
51496           XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
51497           AXMJ=ABS(XMJ)
51498           XMF=PMAS(IFL,1)
51499           IF(AXMI.GE.AXMJ+XMF) THEN
51500 C...Minus sign difference from gluino-quark-squark feynman rules
51501             AL=SFMIX(IFL,1)
51502             BL=-SFMIX(IFL,3)
51503             AR=SFMIX(IFL,2)
51504             BR=-SFMIX(IFL,4)
51505 C...F1 -> F CHI
51506             IF(ILR.EQ.1) THEN
51507               CA=AL
51508               CB=BL
51509 C...F2 -> F CHI
51510             ELSE
51511               CA=AR
51512               CB=BR
51513             ENDIF
51514             LKNT=LKNT+1
51515             XMA2=XMJ**2
51516             XMB2=XMF**2
51517             XL=PYLAMF(XMI2,XMA2,XMB2)
51518             XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
51519      &      (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
51520             IDLAM(LKNT,1)=ILR*KSUSY1+IFL
51521             IDLAM(LKNT,2)=-IFL
51522             IDLAM(LKNT,3)=0
51523             LKNT=LKNT+1
51524             XLAM(LKNT)=XLAM(LKNT-1)
51525             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51526             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51527             IDLAM(LKNT,3)=0
51528           ENDIF
51529   100   CONTINUE
51530   110 CONTINUE
51531  
51532 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
51533 C...GLUINO -> NI Q QBAR
51534       DO 170 IX=1,4
51535         XMJ=SMZ(IX)
51536         AXMJ=ABS(XMJ)
51537         IF(AXMI.GE.AXMJ) THEN
51538           DO 120 I=1,4
51539             ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
51540   120     CONTINUE
51541           OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
51542           ORPP=DCONJG(OLPP)
51543           XXC(1)=0D0
51544           XXC(2)=XMJ
51545           XXC(3)=0D0
51546           XXC(4)=XMI
51547           IA=1
51548           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51549           XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51550           XXC(7)=XXC(5)
51551           XXC(8)=XXC(6)
51552           XXC(9)=1D6
51553           XXC(10)=0D0
51554           EI=KCHG(IA,1)/3D0
51555           T3I=SIGN(1D0,EI+1D-6)/2D0
51556           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51557           GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51558           CXC(1)=0D0
51559           CXC(2)=-GLIJ
51560           CXC(3)=0D0
51561           CXC(4)=DCONJG(GLIJ)
51562           CXC(5)=0D0
51563           CXC(6)=GRIJ
51564           CXC(7)=0D0
51565           CXC(8)=-DCONJG(GRIJ)
51566           S12MIN=0D0
51567           S12MAX=(AXMI-AXMJ)**2
51568           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
51569           IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51570             LKNT=LKNT+1
51571             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51572      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51573             IDLAM(LKNT,1)=KFNCHI(IX)
51574             IDLAM(LKNT,2)=1
51575             IDLAM(LKNT,3)=-1
51576           ENDIF
51577           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51578             LKNT=LKNT+1
51579             XLAM(LKNT)=XLAM(LKNT-1)
51580             IDLAM(LKNT,1)=KFNCHI(IX)
51581             IDLAM(LKNT,2)=3
51582             IDLAM(LKNT,3)=-3
51583           ENDIF
51584   130     CONTINUE
51585           IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51586             PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
51587             IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
51588               GOTO 140
51589             ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
51590               PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
51591             ENDIF
51592             CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
51593             LKNT=LKNT+1
51594             XLAM(LKNT)=GAM
51595             IDLAM(LKNT,1)=KFNCHI(IX)
51596             IDLAM(LKNT,2)=5
51597             IDLAM(LKNT,3)=-5
51598             PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
51599           ENDIF
51600 C...U-TYPE QUARKS
51601   140     CONTINUE
51602           IA=2
51603           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51604           XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51605 C        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
51606           XXC(7)=XXC(5)
51607           XXC(8)=XXC(6)
51608           EI=KCHG(IA,1)/3D0
51609           T3I=SIGN(1D0,EI+1D-6)/2D0
51610           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51611           GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51612           CXC(2)=-GLIJ
51613           CXC(4)=DCONJG(GLIJ)
51614           CXC(6)=GRIJ
51615           CXC(8)=-DCONJG(GRIJ)
51616           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
51617           IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51618             LKNT=LKNT+1
51619             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51620      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51621             IDLAM(LKNT,1)=KFNCHI(IX)
51622             IDLAM(LKNT,2)=2
51623             IDLAM(LKNT,3)=-2
51624           ENDIF
51625           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51626             LKNT=LKNT+1
51627             XLAM(LKNT)=XLAM(LKNT-1)
51628             IDLAM(LKNT,1)=KFNCHI(IX)
51629             IDLAM(LKNT,2)=4
51630             IDLAM(LKNT,3)=-4
51631           ENDIF
51632   150     CONTINUE
51633 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
51634 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
51635           XMF=PMAS(6,1)
51636           IF(AXMI.GE.AXMJ+2D0*XMF) THEN
51637             PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
51638             IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
51639               GOTO 160
51640             ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
51641               PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
51642             ENDIF
51643             CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
51644             LKNT=LKNT+1
51645             XLAM(LKNT)=GAM
51646             IDLAM(LKNT,1)=KFNCHI(IX)
51647             IDLAM(LKNT,2)=6
51648             IDLAM(LKNT,3)=-6
51649             PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
51650           ENDIF
51651   160     CONTINUE
51652         ENDIF
51653   170 CONTINUE
51654  
51655 C...GLUINO -> CI Q QBAR'
51656       DO 210 IX=1,2
51657         XMJ=SMW(IX)
51658         AXMJ=ABS(XMJ)
51659         IF(AXMI.GE.AXMJ) THEN
51660           DO 180 I=1,2
51661             VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
51662             UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
51663   180     CONTINUE
51664           S12MIN=0D0
51665           S12MAX=(AXMI-AXMJ)**2
51666           XXC(1)=0D0
51667           XXC(2)=XMJ
51668           XXC(3)=0D0
51669           XXC(4)=XMI
51670           XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51671           XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51672           XXC(9)=1D6
51673           XXC(10)=0D0
51674           OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51675           ORPP=DCONJG(OLPP)
51676           CXC(1)=DCMPLX(0D0,0D0)
51677           CXC(3)=DCMPLX(0D0,0D0)
51678           CXC(5)=DCMPLX(0D0,0D0)
51679           CXC(7)=DCMPLX(0D0,0D0)
51680           CXC(2)=UMIXC(IX,1)*OLPP/SR2
51681           CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51682           CXC(6)=DCMPLX(0D0,0D0)
51683           CXC(8)=DCMPLX(0D0,0D0)
51684           IF(XXC(5).LT.AXMI) THEN
51685             XXC(5)=1D6
51686           ELSEIF(XXC(6).LT.AXMI) THEN
51687             XXC(6)=1D6
51688           ENDIF
51689           XXC(7)=XXC(6)
51690           XXC(8)=XXC(5)
51691           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
51692           IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51693             LKNT=LKNT+1
51694             XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51695      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51696             IDLAM(LKNT,1)=KFCCHI(IX)
51697             IDLAM(LKNT,2)=1
51698             IDLAM(LKNT,3)=-2
51699             LKNT=LKNT+1
51700             XLAM(LKNT)=XLAM(LKNT-1)
51701             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51702             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51703             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51704           ENDIF
51705           IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51706             LKNT=LKNT+1
51707             XLAM(LKNT)=XLAM(LKNT-1)
51708             IDLAM(LKNT,1)=KFCCHI(IX)
51709             IDLAM(LKNT,2)=3
51710             IDLAM(LKNT,3)=-4
51711             LKNT=LKNT+1
51712             XLAM(LKNT)=XLAM(LKNT-1)
51713             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51714             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51715             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51716           ENDIF
51717   190     CONTINUE
51718  
51719           XMF=PMAS(6,1)
51720           XMFP=PMAS(5,1)
51721           IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
51722             IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
51723      $      PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
51724             PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
51725             PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
51726             PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
51727             PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
51728             IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
51729             IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
51730             IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
51731             IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
51732             CALL PYTBBC(IX,100,XMI,GAM)
51733             LKNT=LKNT+1
51734             XLAM(LKNT)=GAM
51735             IDLAM(LKNT,1)=KFCCHI(IX)
51736             IDLAM(LKNT,2)=5
51737             IDLAM(LKNT,3)=-6
51738             LKNT=LKNT+1
51739             XLAM(LKNT)=XLAM(LKNT-1)
51740             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51741             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51742             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51743             PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
51744             PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
51745             PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
51746             PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
51747           ENDIF
51748   200     CONTINUE
51749         ENDIF
51750   210 CONTINUE
51751  
51752 C...R-parity violating (3-body) decays.
51753       CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
51754  
51755       IKNT=LKNT
51756       XLAM(0)=0D0
51757       DO 220 I=1,IKNT
51758         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51759         XLAM(0)=XLAM(0)+XLAM(I)
51760   220 CONTINUE
51761       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51762  
51763       RETURN
51764       END
51765  
51766  
51767 C*********************************************************************
51768  
51769 C...PYTBBN
51770 C...Calculates the three-body decay of gluinos into
51771 C...neutralinos and third generation fermions.
51772  
51773       SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
51774  
51775 C...Double precision and integer declarations.
51776       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51777       IMPLICIT INTEGER(I-N)
51778       INTEGER PYK,PYCHGE,PYCOMP
51779 C...Parameter statement to help give large particle numbers.
51780       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51781      &KEXCIT=4000000,KDIMEN=5000000)
51782 C...Commonblocks.
51783       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51784       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51785       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51786       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51787      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51788       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51789  
51790 C...Local variables.
51791       EXTERNAL PYSIMP,PYLAMF
51792       DOUBLE PRECISION PYSIMP,PYLAMF
51793       INTEGER LIN,NN
51794       DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
51795       DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
51796       DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
51797       DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
51798       DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
51799       DOUBLE PRECISION XLN1,XLN2,B1,B2
51800       DOUBLE PRECISION E,XMGLU,GAM
51801       DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
51802       SAVE HRB,HLB,FLB,FRB
51803       DOUBLE PRECISION ALPHAW,ALPHAS
51804       DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
51805       SAVE HLT,HRT,FLT,FRT
51806       DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
51807       SAVE AMN,AN,ZN
51808       DOUBLE PRECISION AMBOT,SINC,COSC
51809       DOUBLE PRECISION AMTOP,SINA,COSA
51810       DOUBLE PRECISION SINW,COSW,TANW
51811       DOUBLE PRECISION ROT1(4,4)
51812       LOGICAL IFIRST
51813       SAVE IFIRST
51814       DATA IFIRST/.TRUE./
51815  
51816       TANB=RMSS(5)
51817       SINB=TANB/SQRT(1D0+TANB**2)
51818       COSB=SINB/TANB
51819       XW=PARU(102)
51820       SINW=SQRT(XW)
51821       COSW=SQRT(1D0-XW)
51822       TANW=SINW/COSW
51823       AMW=PMAS(24,1)
51824       COSC=SFMIX(5,1)
51825       SINC=SFMIX(5,3)
51826       COSA=SFMIX(6,1)
51827       SINA=SFMIX(6,3)
51828       AMBOT=PYMRUN(5,XMGLU**2)
51829       AMTOP=PYMRUN(6,XMGLU**2)
51830       W2=SQRT(2D0)
51831       FAKT1=AMBOT/W2/AMW/COSB
51832       FAKT2=AMTOP/W2/AMW/SINB
51833       IF(IFIRST) THEN
51834         DO 110 II=1,4
51835           AMN(II)=SMZ(II)
51836           DO 100 J=1,4
51837             ROT1(II,J)=0D0
51838             AN(II,J)=0D0
51839   100     CONTINUE
51840   110   CONTINUE
51841         ROT1(1,1)=COSW
51842         ROT1(1,2)=-SINW
51843         ROT1(2,1)=-ROT1(1,2)
51844         ROT1(2,2)=ROT1(1,1)
51845         ROT1(3,3)=COSB
51846         ROT1(3,4)=SINB
51847         ROT1(4,3)=-ROT1(3,4)
51848         ROT1(4,4)=ROT1(3,3)
51849         DO 140 II=1,4
51850           DO 130 J=1,4
51851             DO 120 JJ=1,4
51852               AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51853   120       CONTINUE
51854   130     CONTINUE
51855   140   CONTINUE
51856         DO 150 J=1,4
51857           ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51858           ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51859           ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51860      &    XW)*AN(J,2)/COSW
51861           HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51862           HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51863           FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51864           FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51865 C          FLU(J)=ZN(3)
51866 C          FRU(J)=ZN(2)
51867           ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51868           ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51869           ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51870           HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51871           HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51872           FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51873           FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51874 C          FLD(J)=ZN(3)
51875 C          FRD(J)=ZN(2)
51876   150   CONTINUE
51877 C        AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51878 C        AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51879 C        AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51880 C        AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51881         IFIRST=.FALSE.
51882       ENDIF
51883  
51884       IF(NINT(3D0*E).EQ.2) THEN
51885         HL=HLT(I)
51886         HR=HRT(I)
51887         FL=FLT(I)
51888         FR=FRT(I)
51889         COSD=SFMIX(6,1)
51890         SIND=SFMIX(6,3)
51891         XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51892         XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51893         XM=PMAS(6,1)
51894       ELSE
51895         HL=HLB(I)
51896         HR=HRB(I)
51897         FL=FLB(I)
51898         FR=FRB(I)
51899         COSD=SFMIX(5,1)
51900         SIND=SFMIX(5,3)
51901         XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51902         XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51903         XM=PMAS(5,1)
51904       ENDIF
51905       COSD2=COSD*COSD
51906       SIND2=SIND*SIND
51907       COS2D=COSD2-SIND2
51908       SIN2D=SIND*COSD*2D0
51909       HL2=HL*HL
51910       HR2=HR*HR
51911       FL2=FL*FL
51912       FR2=FR*FR
51913       FF=FL*FR
51914       HH=HL*HR
51915       HFL=HL*FL
51916       HFR=HR*FR
51917       HRFL=HR*FL
51918       HLFR=HL*FR
51919       XM2=XM*XM
51920       XMG=XMGLU
51921       XMG2=XMG*XMG
51922       ALPHAW=PYALEM(XMG2)
51923       ALPHAS=PYALPS(XMG2)
51924       XMR=AMN(I)
51925       XMR2=XMR*XMR
51926       XMQ4=XMG*XM2*XMR
51927       XM24=(XMG2+XM2)*(XM2+XMR2)
51928       SMIN=4D0*XM2
51929       SMAX=(XMG-ABS(XMR))**2
51930       XMQA=XMG2+2D0*XM2+XMR2
51931       DO 170 LIN=1,NN-1
51932         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51933         GRS=SBAR-XMQA
51934         W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51935         W=DSQRT(W)
51936         XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51937         XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51938         B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51939         B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51940         G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51941      &  +2D0*(FF*SIND2-HH*COSD2))*W
51942         G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51943      &  +4D0*HFL*XM*XMR)*XLN1
51944      &  +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51945      &  +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51946      &  -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51947      &  +8D0*HFL*XMQ4*SIN2D)*B1
51948         G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51949      &  +4D0*HFR*XMR*XM)*XLN2
51950      &  +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51951      &  +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51952      &  +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51953      &  -8D0*HFR*XMQ4*SIN2D)*B2
51954         G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51955      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51956      &  -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51957      &  +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51958      &  -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51959         G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51960      &  (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51961      &  +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51962         G(5)=(2D0*(HH*COSD2-FF*SIND2)
51963      &  *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51964      &  +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51965      &  +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51966      &  *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51967      &  +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51968      &  +COS2D*XM*(SBAR+XMG2-XMR2))
51969      &  +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51970      &  *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51971         G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51972      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51973      &  -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51974      &  -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51975      &  -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51976         SUMME(LIN)=0D0
51977         DO 160 J=0,6
51978           SUMME(LIN)=SUMME(LIN)+G(J)
51979   160   CONTINUE
51980   170 CONTINUE
51981       SUMME(0)=0D0
51982       SUMME(NN)=0D0
51983       GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51984      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51985  
51986       RETURN
51987       END
51988  
51989 C*********************************************************************
51990  
51991 C...PYTBBC
51992 C...Calculates the three-body decay of gluinos into
51993 C...charginos and third generation fermions.
51994  
51995       SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51996  
51997 C...Double precision and integer declarations.
51998       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51999       IMPLICIT INTEGER(I-N)
52000       INTEGER PYK,PYCHGE,PYCOMP
52001 C...Parameter statement to help give large particle numbers.
52002       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52003      &KEXCIT=4000000,KDIMEN=5000000)
52004 C...Commonblocks.
52005       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52006       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52007       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52008       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52009      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52010       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
52011  
52012 C...Local variables.
52013       EXTERNAL PYSIMP,PYLAMF
52014       DOUBLE PRECISION PYSIMP,PYLAMF
52015       INTEGER I,NN,LIN
52016       DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
52017       DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
52018       DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
52019       DOUBLE PRECISION SUMME(0:100),A(4,8)
52020       DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
52021       DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
52022       DOUBLE PRECISION XMGLU,GAM
52023       DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
52024      &DDD(2),EEE(2),FFF(2)
52025       SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
52026       DOUBLE PRECISION ALPHAW,ALPHAS
52027       DOUBLE PRECISION AMC(2)
52028       SAVE AMC
52029       DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
52030       DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
52031       SAVE AMSB,AMST
52032       LOGICAL IFIRST
52033       SAVE IFIRST
52034       DATA IFIRST/.TRUE./
52035  
52036       TANB=RMSS(5)
52037       SINB=TANB/SQRT(1D0+TANB**2)
52038       COSB=SINB/TANB
52039       XW=PARU(102)
52040       AMW=PMAS(24,1)
52041       COSC=SFMIX(5,1)
52042       SINC=SFMIX(5,3)
52043       COSA=SFMIX(6,1)
52044       SINA=SFMIX(6,3)
52045       AMBOT=PYMRUN(5,XMGLU**2)
52046       AMTOP=PYMRUN(6,XMGLU**2)
52047       W2=SQRT(2D0)
52048       AMW=PMAS(24,1)
52049       FAKT1=AMBOT/W2/AMW/COSB
52050       FAKT2=AMTOP/W2/AMW/SINB
52051       IF(IFIRST) THEN
52052         AMC(1)=SMW(1)
52053         AMC(2)=SMW(2)
52054         DO 100 JJ=1,2
52055           CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
52056           EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
52057           DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
52058           FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
52059           XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
52060           AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
52061           XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
52062           BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
52063   100   CONTINUE
52064         AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
52065         AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
52066         AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
52067         AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
52068         IFIRST=.FALSE.
52069       ENDIF
52070  
52071       ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
52072       ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
52073       VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
52074       VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
52075  
52076       COS2A=COSA**2-SINA**2
52077       SIN2A=SINA*COSA*2D0
52078       COS2C=COSC**2-SINC**2
52079       SIN2C=SINC*COSC*2D0
52080  
52081       XMG=XMGLU
52082       XMT=PMAS(6,1)
52083       XMB=PMAS(5,1)
52084       XMR=AMC(I)
52085       XMG2=XMG*XMG
52086       ALPHAW=PYALEM(XMG2)
52087       ALPHAS=PYALPS(XMG2)
52088       XMT2=XMT*XMT
52089       XMB2=XMB*XMB
52090       XMR2=XMR*XMR
52091       XMQ2=XMG2+XMT2+XMB2+XMR2
52092       XMQ4=XMG*XMT*XMB*XMR
52093       XMQ3=XMG2*XMR2+XMT2*XMB2
52094       XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
52095       XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
52096  
52097       XMST(1)=AMST(1)*AMST(1)
52098       XMST(2)=AMST(1)*AMST(1)
52099       XMST(3)=AMST(2)*AMST(2)
52100       XMST(4)=AMST(2)*AMST(2)
52101       XMSB(1)=AMSB(1)*AMSB(1)
52102       XMSB(2)=AMSB(2)*AMSB(2)
52103       XMSB(3)=AMSB(1)*AMSB(1)
52104       XMSB(4)=AMSB(2)*AMSB(2)
52105  
52106       A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
52107       A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
52108       A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
52109       A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
52110       A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
52111       A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
52112       A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
52113       A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
52114  
52115       A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
52116       A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
52117       A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
52118       A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
52119       A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
52120       A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
52121       A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
52122       A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
52123  
52124       A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
52125       A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
52126       A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
52127       A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
52128       A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
52129       A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
52130       A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
52131       A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
52132  
52133       A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
52134       A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
52135       A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
52136       A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
52137       A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
52138       A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
52139       A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
52140       A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
52141  
52142       SMAX=(XMG-ABS(XMR))**2
52143       SMIN=(XMB+XMT)**2+0.1D0
52144  
52145       DO 120 LIN=0,NN-1
52146         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
52147         AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
52148         GRS=SBAR-XMQ2
52149         W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
52150         W=DSQRT(W)/2D0/SBAR
52151         ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
52152         ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
52153         ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
52154         ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
52155         SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
52156      &  +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
52157      &  +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
52158      &  -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
52159      &  +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
52160      &  +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
52161      &  *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
52162         SUMME(LIN)=SUMME(LIN)-ULR(2)*W
52163      &  +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
52164      &  -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
52165      &  +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
52166      &  +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
52167      &  -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
52168      &  +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
52169      &  *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
52170         SUMME(LIN)=SUMME(LIN)-VLR(1)*W
52171      &  +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
52172      &  +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
52173      &  +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
52174      &  -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
52175      &  +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
52176      &  +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
52177      &  *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
52178         SUMME(LIN)=SUMME(LIN)-VLR(2)*W
52179      &  +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
52180      &  -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
52181      &  +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
52182      &  +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
52183      &  -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
52184      &  +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
52185      &  *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
52186         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
52187      &  *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
52188      &  *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
52189      &  +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
52190         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
52191      &  *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
52192      &  *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
52193      &  +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
52194         DO 110 J=1,4
52195           SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
52196      &    +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
52197      &    +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
52198      &    +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
52199      &    -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
52200      &    -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
52201      &    *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
52202      &    -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
52203      &    +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
52204      &    +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
52205      &    -A(J,6)*(XMG2+XMR2-SBAR)
52206      &    -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
52207      &    *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
52208      &    /(GRS+XMSB(J)+XMST(J))
52209   110   CONTINUE
52210   120 CONTINUE
52211       SUMME(NN)=0D0
52212       GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
52213      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
52214  
52215       RETURN
52216       END
52217  
52218 C*********************************************************************
52219  
52220 C...PYNJDC
52221 C...Calculates decay widths for the neutralinos (admixtures of
52222 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
52223  
52224 C...Input:  KCIN = KF code for particle
52225 C...Output: XLAM = widths
52226 C...        IDLAM = KF codes for decay particles
52227 C...        IKNT = number of decay channels defined
52228 C...AUTHOR: STEPHEN MRENNA
52229 C...Last change:
52230 C...10-15-95:  force decay chi^0_2 -> chi^0_1 + gamma
52231 C...when CHIGAMMA .NE. 0
52232 C...10 FEB 96:  Calculate this decay for small tan(beta)
52233  
52234       SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
52235  
52236 C...Double precision and integer declarations.
52237       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52238       IMPLICIT INTEGER(I-N)
52239       INTEGER PYK,PYCHGE,PYCOMP
52240 C...Parameter statement to help give large particle numbers.
52241       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52242      &KEXCIT=4000000,KDIMEN=5000000)
52243 C...Commonblocks.
52244       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52245       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52246       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52247 c      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52248 c     &SFMIX(16,4)
52249       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52250      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52251 C      COMMON/PYINTS/XXM(20)
52252       COMPLEX*16 CXC
52253       COMMON/PYINTC/XXC(10),CXC(8)
52254       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52255  
52256 C...Local variables.
52257       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
52258       COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
52259       INTEGER KFIN
52260       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52261      &XMZ,XMZ2,AXMJ,AXMI
52262       DOUBLE PRECISION S12MIN,S12MAX
52263       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
52264       DOUBLE PRECISION PYLAMF,XL
52265       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
52266       DOUBLE PRECISION PYX2XH,PYX2XG
52267       DOUBLE PRECISION XLAM(0:400)
52268       INTEGER IDLAM(400,3)
52269       INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
52270       INTEGER ITH(3),KF1,KF2
52271       INTEGER ITHC
52272       DOUBLE PRECISION DH(3),EH(3)
52273       DOUBLE PRECISION SR2
52274       DOUBLE PRECISION CBETA,SBETA
52275       DOUBLE PRECISION GAMCON,XMT1,XMT2
52276       DOUBLE PRECISION PYALEM,PI,PYALPS
52277       DOUBLE PRECISION RAT1,RAT2
52278       DOUBLE PRECISION T3T,FCOL
52279       DOUBLE PRECISION ALFA,BETA,TANB
52280       DOUBLE PRECISION PYXXGA
52281       EXTERNAL PYGAUS,PYXXZ6
52282       DOUBLE PRECISION PYGAUS,PYXXZ6
52283       DOUBLE PRECISION PREC
52284       INTEGER KFNCHI(4),KFCCHI(2)
52285       DATA ITH/25,35,36/
52286       DATA ITHC/37/
52287       DATA PREC/1D-2/
52288       DATA PI/3.141592654D0/
52289       DATA SR2/1.4142136D0/
52290       DATA KFNCHI/1000022,1000023,1000025,1000035/
52291       DATA KFCCHI/1000024,1000037/
52292  
52293 C...COUNT THE NUMBER OF DECAY MODES
52294       LKNT=0
52295  
52296       XMW=PMAS(24,1)
52297       XMW2=XMW**2
52298       XMZ=PMAS(23,1)
52299       XMZ2=XMZ**2
52300       XW=1D0-XMW2/XMZ2
52301       XW1=1D0-XW
52302       TANW = SQRT(XW/XW1)
52303  
52304 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
52305       IX=1
52306       IF(KFIN.EQ.KFNCHI(2)) IX=2
52307       IF(KFIN.EQ.KFNCHI(3)) IX=3
52308       IF(KFIN.EQ.KFNCHI(4)) IX=4
52309  
52310       XMI=SMZ(IX)
52311       XMI2=XMI**2
52312       AXMI=ABS(XMI)
52313       AEM=PYALEM(XMI2)
52314       AS =PYALPS(XMI2)
52315       C1=AEM/XW
52316       XMI3=ABS(XMI**3)
52317  
52318       TANB=RMSS(5)
52319       BETA=ATAN(TANB)
52320       ALFA=RMSS(18)
52321       CBETA=COS(BETA)
52322       SBETA=TANB*CBETA
52323       CALFA=COS(ALFA)
52324       SALFA=SIN(ALFA)
52325  
52326       DO 110 I=1,4
52327         DO 100 J=1,4
52328           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52329   100   CONTINUE
52330   110 CONTINUE
52331       DO 130 I=1,2
52332         DO 120 J=1,2
52333            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52334            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52335   120   CONTINUE
52336   130 CONTINUE
52337  
52338 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52339       IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
52340  
52341 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
52342       IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
52343         XMJ=SMZ(1)
52344         AXMJ=ABS(XMJ)
52345         LKNT=LKNT+1
52346         GAMCON=AEM**3/8D0/PI/XMW2/XW
52347         XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52348         XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52349         XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52350         IDLAM(LKNT,1)=KSUSY1+22
52351         IDLAM(LKNT,2)=22
52352         IDLAM(LKNT,3)=0
52353         WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
52354         GOTO 340
52355       ENDIF
52356  
52357 C...GRAVITINO DECAY MODES
52358  
52359       IF(IMSS(11).EQ.1) THEN
52360         XMP=RMSS(29)
52361         IDG=39+KSUSY1
52362         XMGR=PMAS(PYCOMP(IDG),1)
52363         SINW=SQRT(XW)
52364         COSW=SQRT(1D0-XW)
52365         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52366         IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
52367           LKNT=LKNT+1
52368           IDLAM(LKNT,1)=IDG
52369           IDLAM(LKNT,2)=22
52370           IDLAM(LKNT,3)=0
52371           XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
52372         ENDIF
52373         IF(AXMI.GT.XMGR+XMZ) THEN
52374           LKNT=LKNT+1
52375           IDLAM(LKNT,1)=IDG
52376           IDLAM(LKNT,2)=23
52377           IDLAM(LKNT,3)=0
52378           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
52379      $  .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
52380      &  (1D0-XMZ2/XMI2)**4
52381         ENDIF
52382         IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
52383           LKNT=LKNT+1
52384           IDLAM(LKNT,1)=IDG
52385           IDLAM(LKNT,2)=25
52386           IDLAM(LKNT,3)=0
52387           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
52388      $  .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
52389         ENDIF
52390         IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
52391           LKNT=LKNT+1
52392           IDLAM(LKNT,1)=IDG
52393           IDLAM(LKNT,2)=35
52394           IDLAM(LKNT,3)=0
52395           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
52396      $  .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
52397         ENDIF
52398         IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
52399           LKNT=LKNT+1
52400           IDLAM(LKNT,1)=IDG
52401           IDLAM(LKNT,2)=36
52402           IDLAM(LKNT,3)=0
52403           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
52404      $  .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
52405         ENDIF
52406         IF(IX.EQ.1) GOTO 300
52407       ENDIF
52408  
52409       DO 220 IJ=1,IX-1
52410         XMJ=SMZ(IJ)
52411         AXMJ=ABS(XMJ)
52412         XMJ2=XMJ**2
52413  
52414 C...CHI0_I -> CHI0_J + GAMMA
52415         IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
52416           RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
52417           RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
52418           RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
52419           RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
52420           IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
52421      &    (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
52422             LKNT=LKNT+1
52423             IDLAM(LKNT,1)=KFNCHI(IJ)
52424             IDLAM(LKNT,2)=22
52425             IDLAM(LKNT,3)=0
52426             GAMCON=AEM**3/8D0/PI/XMW2/XW
52427             XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52428             XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52429             XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52430           ENDIF
52431         ENDIF
52432  
52433 C...CHI0_I -> CHI0_J + Z0
52434         IF(AXMI.GE.AXMJ+XMZ) THEN
52435           LKNT=LKNT+1
52436           OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52437      &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52438           ORPP=-DCONJG(OLPP)
52439           GX2=ABS(OLPP)**2+ABS(ORPP)**2
52440           GLR=DBLE(OLPP*DCONJG(ORPP))
52441           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52442           IDLAM(LKNT,1)=KFNCHI(IJ)
52443           IDLAM(LKNT,2)=23
52444           IDLAM(LKNT,3)=0
52445         ELSEIF(AXMI.GE.AXMJ) THEN
52446           XXC(1)=0D0
52447           XXC(2)=XMJ
52448           XXC(3)=0D0
52449           XXC(4)=XMI
52450           XXC(9)=XMZ
52451           XXC(10)=PMAS(23,2)
52452           OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52453      &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52454           ORPP=DCONJG(OLPP)
52455 C...CHARGED LEPTONS
52456           FID=11
52457           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52458           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52459           EI=KCHG(FID,1)/3D0
52460           T3I=SIGN(1D0,EI+1D-6)/2D0
52461           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52462      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52463           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52464           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52465           CXC(2)=-GLIJ
52466           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52467           CXC(4)=DCONJG(GLIJ)
52468           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52469           CXC(6)=GRIJ
52470           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52471           CXC(8)=-DCONJG(GRIJ)
52472           S12MIN=0D0
52473           S12MAX=(AXMI-AXMJ)**2
52474           IF( XXC(5).LT.AXMI ) THEN
52475             XXC(5)=1D6
52476           ENDIF
52477           IF(XXC(6).LT.AXMI ) THEN
52478             XXC(6)=1D6
52479           ENDIF
52480           XXC(7)=XXC(5)
52481           XXC(8)=XXC(6)
52482  
52483           IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52484             LKNT=LKNT+1
52485             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52486      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52487             IDLAM(LKNT,1)=KFNCHI(IJ)
52488             IDLAM(LKNT,2)=FID
52489             IDLAM(LKNT,3)=-FID
52490             IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52491               LKNT=LKNT+1
52492               XLAM(LKNT)=XLAM(LKNT-1)
52493               IDLAM(LKNT,1)=KFNCHI(IJ)
52494               IDLAM(LKNT,2)=13
52495               IDLAM(LKNT,3)=-13
52496             ENDIF
52497           ENDIF
52498   140     CONTINUE
52499           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52500             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52501             XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52502           ELSE
52503             XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52504             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52505           ENDIF
52506           IF( XXC(5).LT.AXMI ) THEN
52507             XXC(5)=1D6
52508           ENDIF
52509           IF(XXC(6).LT.AXMI ) THEN
52510             XXC(6)=1D6
52511           ENDIF
52512           XXC(7)=XXC(5)
52513           XXC(8)=XXC(6)
52514  
52515           IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52516             LKNT=LKNT+1
52517             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52518      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52519             IDLAM(LKNT,1)=KFNCHI(IJ)
52520             IDLAM(LKNT,2)=15
52521             IDLAM(LKNT,3)=-15
52522           ENDIF
52523  
52524 C...NEUTRINOS
52525   150     CONTINUE
52526           FID=12
52527           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52528           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52529           EI=KCHG(FID,1)/3D0
52530           T3I=SIGN(1D0,EI+1D-6)/2D0
52531           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52532      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52533           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52534           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52535           CXC(2)=-GLIJ
52536           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52537           CXC(4)=DCONJG(GLIJ)
52538           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52539           CXC(6)=GRIJ
52540           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52541           CXC(8)=-DCONJG(GRIJ)
52542           S12MIN=0D0
52543           S12MAX=(AXMI-AXMJ)**2
52544           IF( XXC(5).LT.AXMI ) THEN
52545             XXC(5)=1D6
52546           ENDIF
52547           IF( XXC(6).LT.AXMI ) THEN
52548             XXC(6)=1D6
52549           ENDIF
52550           XXC(7)=XXC(5)
52551           XXC(8)=XXC(6)
52552  
52553           LKNT=LKNT+1
52554           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52555      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52556           IDLAM(LKNT,1)=KFNCHI(IJ)
52557           IDLAM(LKNT,2)=12
52558           IDLAM(LKNT,3)=-12
52559           LKNT=LKNT+1
52560           XLAM(LKNT)=XLAM(LKNT-1)
52561           IDLAM(LKNT,1)=KFNCHI(IJ)
52562           IDLAM(LKNT,2)=14
52563           IDLAM(LKNT,3)=-14
52564   160     CONTINUE
52565  
52566           IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
52567      &    THEN
52568             XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52569             IF( XXC(5).LT.AXMI ) THEN
52570               XXC(5)=1D6
52571             ENDIF
52572             XXC(7)=XXC(5)
52573             LKNT=LKNT+1
52574             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52575      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52576           ELSE
52577             LKNT=LKNT+1
52578             XLAM(LKNT)=XLAM(LKNT-1)
52579           ENDIF
52580           IDLAM(LKNT,1)=KFNCHI(IJ)
52581           IDLAM(LKNT,2)=16
52582           IDLAM(LKNT,3)=-16
52583 C...D-TYPE QUARKS
52584   170     CONTINUE
52585           FID=1
52586           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52587           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52588           EI=KCHG(FID,1)/3D0
52589           T3I=SIGN(1D0,EI+1D-6)/2D0
52590           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52591      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52592           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52593           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52594           CXC(2)=-GLIJ
52595           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52596           CXC(4)=DCONJG(GLIJ)
52597           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52598           CXC(6)=GRIJ
52599           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52600           CXC(8)=-DCONJG(GRIJ)
52601           S12MIN=0D0
52602           S12MAX=(AXMI-AXMJ)**2
52603           IF( XXC(5).LT.AXMI ) THEN
52604             XXC(5)=1D6
52605           ENDIF
52606           IF( XXC(6).LT.AXMI ) THEN
52607             XXC(6)=1D6
52608           ENDIF
52609           XXC(7)=XXC(5)
52610           XXC(8)=XXC(6)
52611  
52612           IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52613             LKNT=LKNT+1
52614             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52615      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52616             IDLAM(LKNT,1)=KFNCHI(IJ)
52617             IDLAM(LKNT,2)=1
52618             IDLAM(LKNT,3)=-1
52619             IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52620               LKNT=LKNT+1
52621               XLAM(LKNT)=XLAM(LKNT-1)
52622               IDLAM(LKNT,1)=KFNCHI(IJ)
52623               IDLAM(LKNT,2)=3
52624               IDLAM(LKNT,3)=-3
52625             ENDIF
52626           ENDIF
52627   180     CONTINUE
52628           IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52629             XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52630             XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52631           ELSE
52632             XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52633             XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52634           ENDIF
52635           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52636           IF(XXC(5).LT.AXMI) THEN
52637             XXC(5)=1D6
52638           ELSEIF(XXC(6).LT.AXMI) THEN
52639             XXC(6)=1D6
52640           ENDIF
52641           XXC(7)=XXC(5)
52642           XXC(8)=XXC(6)
52643           IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52644             LKNT=LKNT+1
52645             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52646      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52647             IDLAM(LKNT,1)=KFNCHI(IJ)
52648             IDLAM(LKNT,2)=5
52649             IDLAM(LKNT,3)=-5
52650           ENDIF
52651  
52652 C...U-TYPE QUARKS
52653   190     CONTINUE
52654           FID=2
52655           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52656           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52657           EI=KCHG(FID,1)/3D0
52658           T3I=SIGN(1D0,EI+1D-6)/2D0
52659           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52660      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52661           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52662           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52663           CXC(2)=-GLIJ
52664           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52665           CXC(4)=DCONJG(GLIJ)
52666           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52667           CXC(6)=GRIJ
52668           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52669           CXC(8)=-DCONJG(GRIJ)
52670  
52671           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
52672           IF(XXC(5).LT.AXMI) THEN
52673             XXC(5)=1D6
52674           ELSEIF(XXC(6).LT.AXMI) THEN
52675             XXC(6)=1D6
52676           ENDIF
52677           XXC(7)=XXC(5)
52678           XXC(8)=XXC(6)
52679  
52680           IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52681             LKNT=LKNT+1
52682             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52683      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52684             IDLAM(LKNT,1)=KFNCHI(IJ)
52685             IDLAM(LKNT,2)=2
52686             IDLAM(LKNT,3)=-2
52687             IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52688               LKNT=LKNT+1
52689               XLAM(LKNT)=XLAM(LKNT-1)
52690               IDLAM(LKNT,1)=KFNCHI(IJ)
52691               IDLAM(LKNT,2)=4
52692               IDLAM(LKNT,3)=-4
52693             ENDIF
52694           ENDIF
52695   200     CONTINUE
52696         ENDIF
52697  
52698 C...CHI0_I -> CHI0_J + H0_K
52699         EH(1)=SIN(ALFA)
52700         EH(2)=COS(ALFA)
52701         EH(3)=-SIN(BETA)
52702         DH(1)=COS(ALFA)
52703         DH(2)=-SIN(ALFA)
52704         DH(3)=COS(BETA)
52705         QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
52706      &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
52707      &  TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
52708      &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
52709         RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
52710      &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
52711      &  TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
52712      &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
52713         DO 210 IH=1,3
52714           XMH=PMAS(ITH(IH),1)
52715           XMH2=XMH**2
52716           IF(AXMI.GE.AXMJ+XMH) THEN
52717             LKNT=LKNT+1
52718             XL=PYLAMF(XMI2,XMJ2,XMH2)
52719             F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
52720             F12K=F21K
52721 C...SIGN OF MASSES I,J
52722             XMK=XMJ
52723             IF(IH.EQ.3) XMK=-XMK
52724             GX2=ABS(F21K)**2+ABS(F12K)**2
52725             GLR=DBLE(F21K*DCONJG(F12K))
52726             XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52727             IDLAM(LKNT,1)=KFNCHI(IJ)
52728             IDLAM(LKNT,2)=ITH(IH)
52729             IDLAM(LKNT,3)=0
52730           ENDIF
52731   210   CONTINUE
52732   220 CONTINUE
52733  
52734 C...CHI0_I -> CHI+_J + W-
52735       DO 260 IJ=1,2
52736         XMJ=SMW(IJ)
52737         AXMJ=ABS(XMJ)
52738         XMJ2=XMJ**2
52739         IF(AXMI.GE.AXMJ+XMW) THEN
52740           LKNT=LKNT+1
52741           CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52742      &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
52743           CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52744      &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
52745           GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52746           GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52747           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52748           IDLAM(LKNT,1)=KFCCHI(IJ)
52749           IDLAM(LKNT,2)=-24
52750           IDLAM(LKNT,3)=0
52751           LKNT=LKNT+1
52752           XLAM(LKNT)=XLAM(LKNT-1)
52753           IDLAM(LKNT,1)=-KFCCHI(IJ)
52754           IDLAM(LKNT,2)=24
52755           IDLAM(LKNT,3)=0
52756         ELSEIF(AXMI.GE.AXMJ) THEN
52757           S12MIN=0D0
52758           S12MAX=(AXMI-AXMJ)**2
52759           RT2I = 1D0/SQRT(2D0)
52760           CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52761      &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
52762           CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52763      &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
52764           CXC(5)=DCMPLX(0D0,0D0)
52765           CXC(7)=DCMPLX(0D0,0D0)
52766           IA=11
52767           JA=12
52768           EI=KCHG(IA,1)/3D0
52769           T3I=SIGN(1D0,EI+1D-6)/2D0
52770           EJ=KCHG(JA,1)/3D0
52771           T3J=SIGN(1D0,EJ+1D-6)/2D0
52772           CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52773      &    TANW+ZMIXC(IX,2)*T3J)*RT2I
52774           CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52775      &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
52776           CXC(6)=DCMPLX(0D0,0D0)
52777           CXC(8)=DCMPLX(0D0,0D0)
52778           XXC(1)=0D0
52779           XXC(2)=XMJ
52780           XXC(3)=0D0
52781           XXC(4)=XMI
52782           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52783           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52784           XXC(9)=PMAS(24,1)
52785           XXC(10)=PMAS(24,2)
52786           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
52787           IF(XXC(5).LT.AXMI) THEN
52788             XXC(5)=1D6
52789           ELSEIF(XXC(6).LT.AXMI) THEN
52790             XXC(6)=1D6
52791           ENDIF
52792           XXC(7)=XXC(6)
52793           XXC(8)=XXC(5)
52794           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52795             LKNT=LKNT+1
52796             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52797      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52798             IDLAM(LKNT,1)=KFCCHI(IJ)
52799             IDLAM(LKNT,2)=11
52800             IDLAM(LKNT,3)=-12
52801             LKNT=LKNT+1
52802             XLAM(LKNT)=XLAM(LKNT-1)
52803             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52804             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52805             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52806             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52807               LKNT=LKNT+1
52808               XLAM(LKNT)=XLAM(LKNT-1)
52809               IDLAM(LKNT,1)=KFCCHI(IJ)
52810               IDLAM(LKNT,2)=13
52811               IDLAM(LKNT,3)=-14
52812               LKNT=LKNT+1
52813               XLAM(LKNT)=XLAM(LKNT-1)
52814               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52815               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52816               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52817             ENDIF
52818           ENDIF
52819   230     CONTINUE
52820           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52821             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52822             XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52823           ELSE
52824             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52825             XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52826           ENDIF
52827           IF(XXC(5).LT.AXMI) THEN
52828             XXC(5)=1D6
52829           ENDIF
52830           IF(XXC(6).LT.AXMI) THEN
52831             XXC(6)=1D6
52832           ENDIF
52833           XXC(7)=XXC(6)
52834           XXC(8)=XXC(5)
52835           IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52836             LKNT=LKNT+1
52837             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52838      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52839             XLAM(LKNT)=XLAM(LKNT-1)
52840             IDLAM(LKNT,1)=KFCCHI(IJ)
52841             IDLAM(LKNT,2)=15
52842             IDLAM(LKNT,3)=-16
52843             LKNT=LKNT+1
52844             XLAM(LKNT)=XLAM(LKNT-1)
52845             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52846             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52847             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52848           ENDIF
52849  
52850 C...NOW, DO THE QUARKS
52851   240     CONTINUE
52852           IA=1
52853           JA=2
52854           EI=KCHG(IA,1)/3D0
52855           T3I=SIGN(1D0,EI+1D-6)/2D0
52856           EJ=KCHG(JA,1)/3D0
52857           T3J=SIGN(1D0,EJ+1D-6)/2D0
52858           CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52859      &    TANW+ZMIXC(IX,2)*T3J)
52860           CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52861      &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52862           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52863           XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52864           IF(XXC(5).LT.AXMI) THEN
52865             XXC(5)=1D6
52866           ENDIF
52867           IF(XXC(6).LT.AXMI) THEN
52868             XXC(6)=1D6
52869           ENDIF
52870           XXC(7)=XXC(6)
52871           XXC(8)=XXC(5)
52872           IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52873             LKNT=LKNT+1
52874             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52875      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52876             IDLAM(LKNT,1)=KFCCHI(IJ)
52877             IDLAM(LKNT,2)=1
52878             IDLAM(LKNT,3)=-2
52879             LKNT=LKNT+1
52880             XLAM(LKNT)=XLAM(LKNT-1)
52881             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52882             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52883             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52884             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52885               LKNT=LKNT+1
52886               XLAM(LKNT)=XLAM(LKNT-1)
52887               IDLAM(LKNT,1)=KFCCHI(IJ)
52888               IDLAM(LKNT,2)=3
52889               IDLAM(LKNT,3)=-4
52890               LKNT=LKNT+1
52891               XLAM(LKNT)=XLAM(LKNT-1)
52892               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52893               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52894               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52895             ENDIF
52896           ENDIF
52897   250     CONTINUE
52898         ENDIF
52899   260 CONTINUE
52900   270 CONTINUE
52901  
52902 C...CHI0_I -> CHI+_I + H-
52903       DO 280 IJ=1,2
52904         XMJ=SMW(IJ)
52905         AXMJ=ABS(XMJ)
52906         XMJ2=XMJ**2
52907         XMHP=PMAS(ITHC,1)
52908         IF(AXMI.GE.AXMJ+XMHP) THEN
52909           LKNT=LKNT+1
52910           OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52911      &    ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52912           ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52913      &    (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52914      &    UMIXC(IJ,2)/SR2)
52915           GX2=ABS(OLPP)**2+ABS(ORPP)**2
52916           GLR=DBLE(OLPP*DCONJG(ORPP))
52917           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52918           IDLAM(LKNT,1)=KFCCHI(IJ)
52919           IDLAM(LKNT,2)=-ITHC
52920           IDLAM(LKNT,3)=0
52921           LKNT=LKNT+1
52922           XLAM(LKNT)=XLAM(LKNT-1)
52923           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52924           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52925           IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52926         ELSE
52927  
52928         ENDIF
52929   280 CONTINUE
52930  
52931 C...2-BODY DECAYS TO FERMION SFERMION
52932       DO 290 J=1,16
52933         IF(J.GE.7.AND.J.LE.10) GOTO 290
52934         KF1=KSUSY1+J
52935         KF2=KSUSY2+J
52936         XMSF1=PMAS(PYCOMP(KF1),1)
52937         XMSF2=PMAS(PYCOMP(KF2),1)
52938         XMF=PMAS(J,1)
52939         IF(J.LE.6) THEN
52940           FCOL=3D0
52941         ELSE
52942           FCOL=1D0
52943         ENDIF
52944  
52945         EI=KCHG(J,1)/3D0
52946         T3T=SIGN(1D0,EI)
52947         IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52948         IF(MOD(J,2).EQ.0) THEN
52949           CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52950           CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52951           CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52952           CBR=CAL
52953         ELSE
52954           CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52955           CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52956           CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52957           CBR=CAL
52958         ENDIF
52959  
52960 C...D~ D_L
52961         IF(AXMI.GE.XMF+XMSF1) THEN
52962           LKNT=LKNT+1
52963           XMA2=XMSF1**2
52964           XMB2=XMF**2
52965           XL=PYLAMF(XMI2,XMA2,XMB2)
52966           CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52967           CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52968           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52969      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52970           IDLAM(LKNT,1)=KF1
52971           IDLAM(LKNT,2)=-J
52972           IDLAM(LKNT,3)=0
52973           LKNT=LKNT+1
52974           XLAM(LKNT)=XLAM(LKNT-1)
52975           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52976           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52977           IDLAM(LKNT,3)=0
52978         ENDIF
52979  
52980 C...D~ D_R
52981         IF(AXMI.GE.XMF+XMSF2) THEN
52982           LKNT=LKNT+1
52983           XMA2=XMSF2**2
52984           XMB2=XMF**2
52985           CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52986           CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52987           XL=PYLAMF(XMI2,XMA2,XMB2)
52988           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52989      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52990           IDLAM(LKNT,1)=KF2
52991           IDLAM(LKNT,2)=-J
52992           IDLAM(LKNT,3)=0
52993           LKNT=LKNT+1
52994           XLAM(LKNT)=XLAM(LKNT-1)
52995           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52996           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52997           IDLAM(LKNT,3)=0
52998         ENDIF
52999   290 CONTINUE
53000   300 CONTINUE
53001 C...3-BODY DECAY TO Q Q~ GLUINO
53002       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
53003       IF(AXMI.GE.XMJ) THEN
53004         RT2I = 1D0/SQRT(2D0)
53005         OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
53006         ORPP=DCONJG(OLPP)
53007         AXMJ=ABS(XMJ)
53008         XXC(1)=0D0
53009         XXC(2)=XMJ
53010         XXC(3)=0D0
53011         XXC(4)=XMI
53012         FID=1
53013         XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
53014         XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
53015         XXC(7)=XXC(5)
53016         XXC(8)=XXC(6)
53017         XXC(9)=1D6
53018         XXC(10)=0D0
53019         EI=KCHG(FID,1)/3D0
53020         T3I=SIGN(1D0,EI+1D-6)/2D0
53021         GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
53022         GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
53023         CXC(1)=0D0
53024         CXC(2)=-GLIJ
53025         CXC(3)=0D0
53026         CXC(4)=DCONJG(GLIJ)
53027         CXC(5)=0D0
53028         CXC(6)=GRIJ
53029         CXC(7)=0D0
53030         CXC(8)=-DCONJG(GRIJ)
53031         S12MIN=0D0
53032         S12MAX=(AXMI-AXMJ)**2
53033 CMRENNA.This statement must be here to define S12MAX
53034         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
53035 C...ALL QUARKS BUT T
53036         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53037           LKNT=LKNT+1
53038           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53039      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53040           IDLAM(LKNT,1)=KSUSY1+21
53041           IDLAM(LKNT,2)=1
53042           IDLAM(LKNT,3)=-1
53043           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53044             LKNT=LKNT+1
53045             XLAM(LKNT)=XLAM(LKNT-1)
53046             IDLAM(LKNT,1)=KSUSY1+21
53047             IDLAM(LKNT,2)=3
53048             IDLAM(LKNT,3)=-3
53049           ENDIF
53050         ENDIF
53051   310   CONTINUE
53052         IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53053           XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53054           XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
53055         ELSE
53056           XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
53057           XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53058         ENDIF
53059         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
53060         XXC(7)=XXC(5)
53061         XXC(8)=XXC(6)
53062         IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53063           LKNT=LKNT+1
53064           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53065      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53066           IDLAM(LKNT,1)=KSUSY1+21
53067           IDLAM(LKNT,2)=5
53068           IDLAM(LKNT,3)=-5
53069         ENDIF
53070 C...U-TYPE QUARKS
53071   320   CONTINUE
53072         FID=2
53073         XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
53074         XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
53075         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
53076         XXC(7)=XXC(5)
53077         XXC(8)=XXC(6)
53078         EI=KCHG(FID,1)/3D0
53079         T3I=SIGN(1D0,EI+1D-6)/2D0
53080         GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
53081         GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
53082         CXC(2)=-GLIJ
53083         CXC(4)=DCONJG(GLIJ)
53084         CXC(6)=GRIJ
53085         CXC(8)=-DCONJG(GRIJ)
53086         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53087           LKNT=LKNT+1
53088           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53089      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53090           IDLAM(LKNT,1)=KSUSY1+21
53091           IDLAM(LKNT,2)=2
53092           IDLAM(LKNT,3)=-2
53093           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53094             LKNT=LKNT+1
53095             XLAM(LKNT)=XLAM(LKNT-1)
53096             IDLAM(LKNT,1)=KSUSY1+21
53097             IDLAM(LKNT,2)=4
53098             IDLAM(LKNT,3)=-4
53099           ENDIF
53100         ENDIF
53101   330   CONTINUE
53102       ENDIF
53103  
53104 C...R-violating decay modes (SKANDS).
53105       CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
53106  
53107   340 IKNT=LKNT
53108       XLAM(0)=0D0
53109       DO 350 I=1,IKNT
53110         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
53111         XLAM(0)=XLAM(0)+XLAM(I)
53112   350 CONTINUE
53113       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53114  
53115       RETURN
53116       END
53117  
53118 C*********************************************************************
53119  
53120 C...PYCJDC
53121 C...Calculate decay widths for the charginos (admixtures of
53122 C...charged Wino and charged Higgsino.
53123  
53124 C...Input:  KCIN = KF code for particle
53125 C...Output: XLAM = widths
53126 C...        IDLAM = KF codes for decay particles
53127 C...        IKNT = number of decay channels defined
53128 C...AUTHOR: STEPHEN MRENNA
53129 C...Last change:
53130 C...10-16-95:  force decay chi^+_1 -> chi^0_1 e+ nu_e
53131 C...when CHIENU .NE. 0
53132  
53133       SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
53134  
53135 C...Double precision and integer declarations.
53136       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53137       IMPLICIT INTEGER(I-N)
53138       INTEGER PYK,PYCHGE,PYCOMP
53139 C...Parameter statement to help give large particle numbers.
53140       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53141      &KEXCIT=4000000,KDIMEN=5000000)
53142 C...Commonblocks.
53143       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53144       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53145       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53146       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53147      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53148 CC     &SFMIX(16,4),
53149 C      COMMON/PYINTS/XXM(20)
53150       COMPLEX*16 CXC
53151       COMMON/PYINTC/XXC(10),CXC(8)
53152       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
53153  
53154 C...Local variables
53155       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53156       COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
53157       INTEGER KFIN,KCIN
53158       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
53159      &XMZ,XMZ2,AXMJ,AXMI
53160       DOUBLE PRECISION S12MIN,S12MAX
53161       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
53162       DOUBLE PRECISION PYLAMF,XL
53163       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
53164       DOUBLE PRECISION PYX2XH,PYX2XG
53165       DOUBLE PRECISION XLAM(0:400)
53166       INTEGER IDLAM(400,3)
53167       INTEGER LKNT,IX,IH,J,IJ,I,IKNT
53168       INTEGER ITH(3)
53169       INTEGER ITHC
53170       DOUBLE PRECISION ETAH(3),DH(3),EH(3)
53171       DOUBLE PRECISION SR2
53172       DOUBLE PRECISION CBETA,SBETA,TANB
53173  
53174       DOUBLE PRECISION PYALEM,PI,PYALPS
53175       DOUBLE PRECISION FCOL
53176       INTEGER KF1,KF2,ISF
53177       INTEGER KFNCHI(4),KFCCHI(2)
53178  
53179       DOUBLE PRECISION TEMP
53180       EXTERNAL PYGAUS,PYXXZ6
53181       DOUBLE PRECISION PYGAUS,PYXXZ6
53182       DOUBLE PRECISION PREC
53183       DATA ITH/25,35,36/
53184       DATA ITHC/37/
53185       DATA ETAH/1D0,1D0,-1D0/
53186       DATA SR2/1.4142136D0/
53187       DATA PI/3.141592654D0/
53188       DATA PREC/1D-2/
53189       DATA KFNCHI/1000022,1000023,1000025,1000035/
53190       DATA KFCCHI/1000024,1000037/
53191  
53192 C...COUNT THE NUMBER OF DECAY MODES
53193       LKNT=0
53194       XMW=PMAS(24,1)
53195       XMW2=XMW**2
53196       XMZ=PMAS(23,1)
53197       XMZ2=XMZ**2
53198       XW=1D0-XMW2/XMZ2
53199       XW1=1D0-XW
53200       TANW = SQRT(XW/XW1)
53201  
53202 C...1 OR 2 DEPENDING ON CHARGINO TYPE
53203       IX=1
53204       IF(KFIN.EQ.KFCCHI(2)) IX=2
53205       KCIN=PYCOMP(KFIN)
53206  
53207       XMI=SMW(IX)
53208       XMI2=XMI**2
53209       AXMI=ABS(XMI)
53210       AEM=PYALEM(XMI2)
53211       AS =PYALPS(XMI2)
53212       C1=AEM/XW
53213       XMI3=ABS(XMI**3)
53214       TANB=RMSS(5)
53215       BETA=ATAN(TANB)
53216       CBETA=COS(BETA)
53217       SBETA=TANB*CBETA
53218       ALFA=RMSS(18)
53219  
53220       DO 110 I=1,2
53221         DO 100 J=1,2
53222           VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53223           UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53224   100   CONTINUE
53225   110 CONTINUE
53226  
53227 C...GRAVITINO DECAY MODES
53228  
53229       IF(IMSS(11).EQ.1) THEN
53230         XMP=RMSS(29)
53231         IDG=39+KSUSY1
53232         XMGR=PMAS(PYCOMP(IDG),1)
53233 C        SINW=SQRT(XW)
53234 C        COSW=SQRT(1D0-XW)
53235         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
53236         IF(AXMI.GT.XMGR+XMW) THEN
53237           LKNT=LKNT+1
53238           IDLAM(LKNT,1)=IDG
53239           IDLAM(LKNT,2)=24
53240           IDLAM(LKNT,3)=0
53241           XLAM(LKNT)=XFAC*(
53242      &  .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
53243      &  .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
53244      &  (1D0-XMW2/XMI2)**4
53245         ENDIF
53246         IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
53247           LKNT=LKNT+1
53248           IDLAM(LKNT,1)=IDG
53249           IDLAM(LKNT,2)=37
53250           IDLAM(LKNT,3)=0
53251           XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
53252      &   (ABS(UMIXC(IX,2))*SBETA)**2))
53253      &   *(1D0-PMAS(37,1)**2/XMI2)**4
53254        ENDIF
53255       ENDIF
53256  
53257 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53258       IF(IX.EQ.1) GOTO 170
53259       XMJ=SMW(1)
53260       AXMJ=ABS(XMJ)
53261       XMJ2=XMJ**2
53262  
53263 C...CHI_2+ -> CHI_1+ + Z0
53264       IF(AXMI.GE.AXMJ+XMZ) THEN
53265         LKNT=LKNT+1
53266         IJ=1
53267         OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53268      &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53269         ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53270      &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53271         GX2=ABS(OLPP)**2+ABS(ORPP)**2
53272         GLR=DBLE(OLPP*DCONJG(ORPP))
53273         XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
53274         IDLAM(LKNT,1)=KFCCHI(1)
53275         IDLAM(LKNT,2)=23
53276         IDLAM(LKNT,3)=0
53277  
53278 C...CHARGED LEPTONS
53279       ELSEIF(AXMI.GE.AXMJ) THEN
53280         S12MIN=0D0
53281         S12MAX=(AXMI-AXMJ)**2
53282         IA=11
53283         JA=12
53284         EI=KCHG(IABS(IA),1)/3D0
53285         T3I=SIGN(1D0,EI+1D-6)/2D0
53286         XXC(1)=0D0
53287         XXC(2)=XMJ
53288         XXC(3)=0D0
53289         XXC(4)=XMI
53290         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53291         XXC(6)=1D6
53292         XXC(9)=PMAS(23,1)
53293         XXC(10)=PMAS(23,2)
53294         IJ=1
53295         OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53296      &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53297         ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53298      &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53299         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53300         CXC(2)=DCMPLX(0D0,0D0)
53301         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53302         CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53303         CXC(5)=-DCMPLX(EI/XW1)*ORPP
53304         CXC(6)=DCMPLX(0D0,0D0)
53305         CXC(7)=-DCMPLX(EI/XW1)*OLPP
53306         CXC(8)=DCMPLX(0D0,0D0)
53307         IF( XXC(5).LT.AXMI ) THEN
53308           XXC(5)=1D6
53309         ENDIF
53310         XXC(7)=XXC(5)
53311         XXC(8)=XXC(6)
53312         IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
53313           LKNT=LKNT+1
53314           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53315      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53316           IDLAM(LKNT,1)=KFCCHI(1)
53317           IDLAM(LKNT,2)=11
53318           IDLAM(LKNT,3)=-11
53319           IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
53320             LKNT=LKNT+1
53321             XLAM(LKNT)=XLAM(LKNT-1)
53322             IDLAM(LKNT,1)=KFCCHI(1)
53323             IDLAM(LKNT,2)=13
53324             IDLAM(LKNT,3)=-13
53325           ENDIF
53326           IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
53327             LKNT=LKNT+1
53328             XLAM(LKNT)=XLAM(LKNT-1)
53329             IDLAM(LKNT,1)=KFCCHI(1)
53330             IDLAM(LKNT,2)=15
53331             IDLAM(LKNT,3)=-15
53332           ENDIF
53333         ENDIF
53334  
53335 C...NEUTRINOS
53336   120   CONTINUE
53337         IA=12
53338         JA=11
53339         EI=KCHG(IABS(IA),1)/3D0
53340         T3I=SIGN(1D0,EI+1D-6)/2D0
53341         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53342         XXC(6)=1D6
53343         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53344         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53345         CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53346         CXC(5)=-DCMPLX(EI/XW1)*ORPP
53347         CXC(7)=-DCMPLX(EI/XW1)*OLPP
53348         IF( XXC(5).LT.AXMI ) THEN
53349           XXC(5)=1D6
53350         ENDIF
53351         XXC(7)=XXC(5)
53352         XXC(8)=XXC(6)
53353         IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
53354           LKNT=LKNT+1
53355           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53356      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53357           IDLAM(LKNT,1)=KFCCHI(1)
53358           IDLAM(LKNT,2)=12
53359           IDLAM(LKNT,3)=-12
53360           LKNT=LKNT+1
53361           XLAM(LKNT)=XLAM(LKNT-1)
53362           IDLAM(LKNT,1)=KFCCHI(1)
53363           IDLAM(LKNT,2)=14
53364           IDLAM(LKNT,3)=-14
53365         ENDIF
53366         IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
53367           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53368             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
53369           ELSE
53370             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
53371           ENDIF
53372           IF( XXC(5).LT.AXMI ) THEN
53373             XXC(5)=1D6
53374           ENDIF
53375           XXC(7)=XXC(5)
53376           LKNT=LKNT+1
53377           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53378      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53379           IDLAM(LKNT,1)=KFCCHI(1)
53380           IDLAM(LKNT,2)=16
53381           IDLAM(LKNT,3)=-16
53382         ENDIF
53383  
53384 C...D-TYPE QUARKS
53385   130   CONTINUE
53386         IA=1
53387         JA=2
53388         EI=KCHG(IABS(IA),1)/3D0
53389         T3I=SIGN(1D0,EI+1D-6)/2D0
53390         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53391         XXC(6)=1D6
53392         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53393         CXC(2)=DCMPLX(0D0,0D0)
53394         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53395         CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53396         CXC(5)=-DCMPLX(EI/XW1)*ORPP
53397         CXC(6)=DCMPLX(0D0,0D0)
53398         CXC(7)=-DCMPLX(EI/XW1)*OLPP
53399         CXC(8)=DCMPLX(0D0,0D0)
53400         IF( XXC(5).LT.AXMI ) THEN
53401           XXC(5)=1D6
53402         ENDIF
53403         XXC(7)=XXC(5)
53404         XXC(8)=XXC(6)
53405         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53406           LKNT=LKNT+1
53407           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53408      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53409           IDLAM(LKNT,1)=KFCCHI(1)
53410           IDLAM(LKNT,2)=1
53411           IDLAM(LKNT,3)=-1
53412           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53413             LKNT=LKNT+1
53414             XLAM(LKNT)=XLAM(LKNT-1)
53415             IDLAM(LKNT,1)=KFCCHI(1)
53416             IDLAM(LKNT,2)=3
53417             IDLAM(LKNT,3)=-3
53418           ENDIF
53419         ENDIF
53420         IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53421           IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53422             XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53423           ELSE
53424             XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53425           ENDIF
53426           IF( XXC(5).LT.AXMI ) THEN
53427             XXC(5)=1D6
53428           ENDIF
53429           XXC(7)=XXC(5)
53430           LKNT=LKNT+1
53431           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53432      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53433           IDLAM(LKNT,1)=KFCCHI(1)
53434           IDLAM(LKNT,2)=5
53435           IDLAM(LKNT,3)=-5
53436         ENDIF
53437  
53438 C...U-TYPE QUARKS
53439   140   CONTINUE
53440         IA=2
53441         JA=1
53442         EI=KCHG(IABS(IA),1)/3D0
53443         T3I=SIGN(1D0,EI+1D-6)/2D0
53444         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53445         XXC(6)=1D6
53446         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53447         CXC(2)=DCMPLX(0D0,0D0)
53448         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53449         CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53450         CXC(5)=-DCMPLX(EI/XW1)*ORPP
53451         CXC(6)=DCMPLX(0D0,0D0)
53452         CXC(7)=-DCMPLX(EI/XW1)*OLPP
53453         CXC(8)=DCMPLX(0D0,0D0)
53454         IF( XXC(5).LT.AXMI ) THEN
53455           XXC(5)=1D6
53456         ENDIF
53457         XXC(7)=XXC(5)
53458         XXC(8)=XXC(6)
53459         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53460           LKNT=LKNT+1
53461           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53462      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53463           IDLAM(LKNT,1)=KFCCHI(1)
53464           IDLAM(LKNT,2)=2
53465           IDLAM(LKNT,3)=-2
53466           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53467             LKNT=LKNT+1
53468             XLAM(LKNT)=XLAM(LKNT-1)
53469             IDLAM(LKNT,1)=KFCCHI(1)
53470             IDLAM(LKNT,2)=4
53471             IDLAM(LKNT,3)=-4
53472           ENDIF
53473         ENDIF
53474   150   CONTINUE
53475       ENDIF
53476  
53477 C...CHI_2+ -> CHI_1+ + H0_K
53478       EH(2)=COS(ALFA)
53479       EH(1)=SIN(ALFA)
53480       EH(3)=-SBETA
53481       DH(2)=-SIN(ALFA)
53482       DH(1)=COS(ALFA)
53483       DH(3)=COS(BETA)
53484       DO 160 IH=1,3
53485         XMH=PMAS(ITH(IH),1)
53486         XMH2=XMH**2
53487 C...NO 3-BODY OPTION
53488         IF(AXMI.GE.AXMJ+XMH) THEN
53489           LKNT=LKNT+1
53490           XL=PYLAMF(XMI2,XMJ2,XMH2)
53491           OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
53492      &    VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
53493           ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
53494      &    DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
53495           XMK=XMJ*ETAH(IH)
53496           GX2=ABS(OLPP)**2+ABS(ORPP)**2
53497           GLR=DBLE(OLPP*DCONJG(ORPP))
53498           XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
53499           IDLAM(LKNT,1)=KFCCHI(1)
53500           IDLAM(LKNT,2)=ITH(IH)
53501           IDLAM(LKNT,3)=0
53502         ENDIF
53503   160 CONTINUE
53504  
53505 C...CHI1 JUMPS TO HERE
53506   170 CONTINUE
53507  
53508 C...CHI+_I -> CHI0_J + W+
53509       DO 220 IJ=1,4
53510         XMJ=SMZ(IJ)
53511         AXMJ=ABS(XMJ)
53512         XMJ2=XMJ**2
53513         IF(AXMI.GE.AXMJ+XMW) THEN
53514           LKNT=LKNT+1
53515           DO 180 I=1,4
53516             ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53517   180     CONTINUE
53518           CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53519      &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
53520           CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53521      &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
53522           GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
53523           GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
53524           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
53525           IDLAM(LKNT,1)=KFNCHI(IJ)
53526           IDLAM(LKNT,2)=24
53527           IDLAM(LKNT,3)=0
53528 C...LEPTONS
53529         ELSEIF(AXMI.GE.AXMJ) THEN
53530           S12MIN=0D0
53531           S12MAX=(AXMI-AXMJ)**2
53532           DO 190 I=1,4
53533             ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53534   190     CONTINUE
53535           CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53536      &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
53537           CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53538      &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
53539           CXC(5)=DCMPLX(0D0,0D0)
53540           CXC(7)=DCMPLX(0D0,0D0)
53541           IA=11
53542           JA=12
53543           EI=KCHG(IA,1)/3D0
53544           T3I=SIGN(1D0,EI+1D-6)/2D0
53545           EJ=KCHG(JA,1)/3D0
53546           T3J=SIGN(1D0,EJ+1D-6)/2D0
53547           CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53548      &    TANW+ZMIXC(IJ,2)*T3J)/SR2
53549           CXC(4)=-DCONJG(UMIXC(IX,1))*(
53550      &    ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
53551           CXC(6)=DCMPLX(0D0,0D0)
53552           CXC(8)=DCMPLX(0D0,0D0)
53553           XXC(1)=0D0
53554           XXC(2)=XMJ
53555           XXC(3)=0D0
53556           XXC(4)=XMI
53557           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53558           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53559           XXC(9)=PMAS(24,1)
53560           XXC(10)=PMAS(24,2)
53561 CCC          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
53562           IF(XXC(5).LT.AXMI) THEN
53563             XXC(5)=1D6
53564           ELSEIF(XXC(6).LT.AXMI) THEN
53565             XXC(6)=1D6
53566           ENDIF
53567           XXC(7)=XXC(6)
53568           XXC(8)=XXC(5)
53569 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
53570 C...--> 1/(16PI)/M**3*(AEM/XW)**2
53571           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
53572             LKNT=LKNT+1
53573             TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53574             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53575             IDLAM(LKNT,1)=KFNCHI(IJ)
53576             IDLAM(LKNT,2)=-11
53577             IDLAM(LKNT,3)=12
53578 C...ONLY DECAY CHI+1 -> E+ NU_E
53579             IF( IMSS(12).NE. 0 ) GOTO 260
53580             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
53581               LKNT=LKNT+1
53582               XLAM(LKNT)=XLAM(LKNT-1)
53583               IDLAM(LKNT,1)=KFNCHI(IJ)
53584               IDLAM(LKNT,2)=-13
53585               IDLAM(LKNT,3)=14
53586             ENDIF
53587           ENDIF
53588           IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
53589             LKNT=LKNT+1
53590             IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53591               XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
53592             ELSE
53593               XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
53594             ENDIF
53595             XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
53596             IF(XXC(5).LT.AXMI) THEN
53597               XXC(5)=1D6
53598             ELSEIF(XXC(6).LT.AXMI) THEN
53599               XXC(6)=1D6
53600             ENDIF
53601             XXC(7)=XXC(6)
53602             XXC(8)=XXC(5)
53603             TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53604             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53605             IDLAM(LKNT,1)=KFNCHI(IJ)
53606             IDLAM(LKNT,2)=-15
53607             IDLAM(LKNT,3)=16
53608           ENDIF
53609  
53610 C...NOW, DO THE QUARKS
53611   200     CONTINUE
53612           IA=1
53613           JA=2
53614           EI=KCHG(IA,1)/3D0
53615           T3I=SIGN(1D0,EI+1D-6)/2D0
53616           EJ=KCHG(JA,1)/3D0
53617           T3J=SIGN(1D0,EJ+1D-6)/2D0
53618           CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53619      &    TANW+ZMIXC(IJ,2)*T3J)
53620           CXC(4)=-DCONJG(UMIXC(IX,1))*(
53621      &    ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
53622           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53623           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53624           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
53625           IF(XXC(5).LT.AXMI) THEN
53626             XXC(5)=1D6
53627           ENDIF
53628           IF(XXC(6).LT.AXMI) THEN
53629             XXC(6)=1D6
53630           ENDIF
53631           XXC(7)=XXC(6)
53632           XXC(8)=XXC(5)
53633           IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53634             LKNT=LKNT+1
53635             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53636      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53637             IDLAM(LKNT,1)=KFNCHI(IJ)
53638             IDLAM(LKNT,2)=-1
53639             IDLAM(LKNT,3)=2
53640             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53641               LKNT=LKNT+1
53642               XLAM(LKNT)=XLAM(LKNT-1)
53643               IDLAM(LKNT,1)=KFNCHI(IJ)
53644               IDLAM(LKNT,2)=-3
53645               IDLAM(LKNT,3)=4
53646             ENDIF
53647           ENDIF
53648   210     CONTINUE
53649         ENDIF
53650   220 CONTINUE
53651  
53652 C...CHI+_I -> CHI0_J + H+
53653       DO 230 IJ=1,4
53654         XMJ=SMZ(IJ)
53655         AXMJ=ABS(XMJ)
53656         XMJ2=XMJ**2
53657         XMHP=PMAS(ITHC,1)
53658         IF(AXMI.GE.AXMJ+XMHP) THEN
53659           LKNT=LKNT+1
53660           OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
53661      &    ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
53662           ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
53663      &    (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
53664      &    UMIXC(IX,2)/SR2)
53665           GX2=ABS(OLPP)**2+ABS(ORPP)**2
53666           GLR=DBLE(OLPP*DCONJG(ORPP))
53667           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
53668           IDLAM(LKNT,1)=KFNCHI(IJ)
53669           IDLAM(LKNT,2)=ITHC
53670           IDLAM(LKNT,3)=0
53671         ELSE
53672  
53673         ENDIF
53674   230 CONTINUE
53675  
53676 C...2-BODY DECAYS TO FERMION SFERMION
53677       DO 240 J=1,16
53678         IF(J.GE.7.AND.J.LE.10) GOTO 240
53679         IF(MOD(J,2).EQ.0) THEN
53680           KF1=KSUSY1+J-1
53681         ELSE
53682           KF1=KSUSY1+J+1
53683         ENDIF
53684         KF2=KF1+KSUSY1
53685         XMSF1=PMAS(PYCOMP(KF1),1)
53686         XMSF2=PMAS(PYCOMP(KF2),1)
53687         XMF=PMAS(J,1)
53688         IF(J.LE.6) THEN
53689           FCOL=3D0
53690         ELSE
53691           FCOL=1D0
53692         ENDIF
53693  
53694 C...U~ D_L
53695         IF(MOD(J,2).EQ.0) THEN
53696           XMFP=PMAS(J-1,1)
53697           CAL=UMIXC(IX,1)
53698           CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
53699           CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
53700           CBR=0D0
53701           ISF=J-1
53702         ELSE
53703           XMFP=PMAS(J+1,1)
53704           CAL=VMIXC(IX,1)
53705           CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
53706           CBR=0D0
53707           CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
53708           ISF=J+1
53709         ENDIF
53710  
53711 C...~U_L D
53712         IF(AXMI.GE.XMF+XMSF1) THEN
53713           LKNT=LKNT+1
53714           XMA2=XMSF1**2
53715           XMB2=XMF**2
53716           XL=PYLAMF(XMI2,XMA2,XMB2)
53717           CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
53718           CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
53719           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53720      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53721           IDLAM(LKNT,3)=0
53722           IF(MOD(J,2).EQ.0) THEN
53723             IDLAM(LKNT,1)=-KF1
53724             IDLAM(LKNT,2)=J
53725           ELSE
53726             IDLAM(LKNT,1)=KF1
53727             IDLAM(LKNT,2)=-J
53728           ENDIF
53729         ENDIF
53730  
53731 C...U~ D_R
53732         IF(AXMI.GE.XMF+XMSF2) THEN
53733           LKNT=LKNT+1
53734           XMA2=XMSF2**2
53735           XMB2=XMF**2
53736           CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
53737           CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
53738           XL=PYLAMF(XMI2,XMA2,XMB2)
53739           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53740      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53741           IDLAM(LKNT,3)=0
53742           IF(MOD(J,2).EQ.0) THEN
53743             IDLAM(LKNT,1)=-KF2
53744             IDLAM(LKNT,2)=J
53745           ELSE
53746             IDLAM(LKNT,1)=KF2
53747             IDLAM(LKNT,2)=-J
53748           ENDIF
53749         ENDIF
53750   240 CONTINUE
53751  
53752 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
53753 C...A 2-BODY -- 2-BODY CHAIN
53754       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
53755       IF(AXMI.GE.XMJ) THEN
53756         AXMJ=ABS(XMJ)
53757         S12MIN=0D0
53758         S12MAX=(AXMI-AXMJ)**2
53759         XXC(1)=0D0
53760         XXC(2)=XMJ
53761         XXC(3)=0D0
53762         XXC(4)=XMI
53763         XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
53764         XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
53765         XXC(9)=1D6
53766         XXC(10)=0D0
53767         OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
53768         ORPP=DCONJG(OLPP)
53769         CXC(1)=DCMPLX(0D0,0D0)
53770         CXC(3)=DCMPLX(0D0,0D0)
53771         CXC(5)=DCMPLX(0D0,0D0)
53772         CXC(7)=DCMPLX(0D0,0D0)
53773         CXC(2)=UMIXC(IX,1)*OLPP/SR2
53774         CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
53775         CXC(6)=DCMPLX(0D0,0D0)
53776         CXC(8)=DCMPLX(0D0,0D0)
53777         IF(XXC(5).LT.AXMI) THEN
53778           XXC(5)=1D6
53779         ELSEIF(XXC(6).LT.AXMI) THEN
53780           XXC(6)=1D6
53781         ENDIF
53782         XXC(7)=XXC(6)
53783         XXC(8)=XXC(5)
53784         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
53785         IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53786           LKNT=LKNT+1
53787           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53788      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53789           IDLAM(LKNT,1)=KSUSY1+21
53790           IDLAM(LKNT,2)=-1
53791           IDLAM(LKNT,3)=2
53792           IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53793             LKNT=LKNT+1
53794             XLAM(LKNT)=XLAM(LKNT-1)
53795             IDLAM(LKNT,1)=KSUSY1+21
53796             IDLAM(LKNT,2)=-3
53797             IDLAM(LKNT,3)=4
53798           ENDIF
53799         ENDIF
53800   250   CONTINUE
53801       ENDIF
53802  
53803 C...R-violating decay modes (SKANDS).
53804       CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
53805  
53806   260 IKNT=LKNT
53807       XLAM(0)=0D0
53808       DO 270 I=1,IKNT
53809         XLAM(0)=XLAM(0)+XLAM(I)
53810         IF(XLAM(I).LT.0D0) THEN
53811           WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
53812      &    (IDLAM(I,J),J=1,3)
53813           XLAM(I)=0D0
53814         ENDIF
53815   270 CONTINUE
53816       IF(XLAM(0).EQ.0D0) THEN
53817         XLAM(0)=1D-6
53818         WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
53819         WRITE(MSTU(11),*) LKNT
53820         WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
53821       ENDIF
53822  
53823       RETURN
53824       END
53825  
53826 C*********************************************************************
53827  
53828 C...PYXXZ6
53829 C...Used in the calculation of  inoi -> inoj + f + ~f.
53830  
53831       FUNCTION PYXXZ6(X)
53832  
53833 C...Double precision and integer declarations.
53834       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53835       IMPLICIT INTEGER(I-N)
53836       INTEGER PYK,PYCHGE,PYCOMP
53837 C...Parameter statement to help give large particle numbers.
53838       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53839      &KEXCIT=4000000,KDIMEN=5000000)
53840 C...Commonblocks.
53841       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53842 C      COMMON/PYINTS/XXM(20)
53843       COMPLEX*16 CXC
53844       COMMON/PYINTC/XXC(10),CXC(8)
53845       SAVE /PYDAT1/,/PYINTC/
53846  
53847 C...Local variables.
53848       COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53849       DOUBLE PRECISION PYXXZ6,X
53850       DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53851       DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53852       DOUBLE PRECISION SIJ
53853       DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53854       DOUBLE PRECISION OL2
53855       DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53856       INTEGER I
53857  
53858 C...Statement functions.
53859 C...Integral from x to y of (t-a)(b-t) dt.
53860       TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53861 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53862       TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53863      &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53864 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53865       TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53866      &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53867 C...Integral from x to y of (t-a)/(b-t) dt.
53868       UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53869 C...Integral from x to y of 1/(t-a) dt.
53870       TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53871  
53872       XM12=XXC(1)**2
53873       XM22=XXC(2)**2
53874       XM32=XXC(3)**2
53875       S=XXC(4)**2
53876       S13=X
53877  
53878       S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53879       S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53880      &( (X-XM22-S)**2  -4D0*XM22*S  ) )
53881  
53882       S23MIN=(S23AVE-S23DEL)
53883       S23MAX=(S23AVE+S23DEL)
53884  
53885       XMSD1=XXC(5)**2
53886       XMSD2=XXC(7)**2
53887       XMSU1=XXC(6)**2
53888       XMSU2=XXC(8)**2
53889  
53890       XMV=XXC(9)
53891       XMG=XXC(10)
53892       QLLS=CXC(1)
53893       QLLU=CXC(2)
53894       QLRS=CXC(3)
53895       QLRT=CXC(4)
53896       QRLS=CXC(5)
53897       QRLT=CXC(6)
53898       QRRS=CXC(7)
53899       QRRU=CXC(8)
53900       WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53901       SIJ=2D0*XXC(2)*XXC(4)*S13
53902       IF(XMV.LE.1000D0) THEN
53903         OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53904         OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53905         WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53906      &  +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53907         IF(XXC(5).LE.10000D0) THEN
53908           WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53909      &    TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53910      &    .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53911      &    DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53912      &    .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53913      &    *(S13-XMV**2)/WPROP2
53914         ELSE
53915           WFL1=0D0
53916         ENDIF
53917  
53918         IF(XXC(6).LE.10000D0) THEN
53919           WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53920      &    TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53921      &    .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53922      &    DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53923      &    .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53924      &    *(S13-XMV**2)/WPROP2
53925         ELSE
53926           WFL2=0D0
53927         ENDIF
53928       ELSE
53929         WW=0D0
53930         WFL1=0D0
53931         WFL2=0D0
53932       ENDIF
53933       IF(XXC(5).LE.10000D0) THEN
53934         WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53935      &  +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53936      &  - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53937      &  SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53938       ELSE
53939         WF1=0D0
53940       ENDIF
53941       IF(XXC(6).LE.10000D0) THEN
53942         WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53943      &  +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53944      &  - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53945      &  SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53946       ELSE
53947         WF2=0D0
53948       ENDIF
53949  
53950       PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53951  
53952       IF(PYXXZ6.LT.0D0) THEN
53953         WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53954         WRITE(MSTU(11),*) (XXC(I),I=1,5)
53955         WRITE(MSTU(11),*) (XXC(I),I=6,10)
53956         WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53957         WRITE(MSTU(11),*) S23MIN,S23MAX
53958         PYXXZ6=0D0
53959       ENDIF
53960  
53961       RETURN
53962       END
53963  
53964  
53965 C*********************************************************************
53966  
53967 C...PYXXGA
53968 C...Calculates chi0_i -> chi0_j + gamma.
53969  
53970       FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53971  
53972 C...Double precision and integer declarations.
53973       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53974       IMPLICIT INTEGER(I-N)
53975       INTEGER PYK,PYCHGE,PYCOMP
53976  
53977 C...Local variables.
53978       DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53979       DOUBLE PRECISION F1,F2
53980  
53981       F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53982       F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53983       PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53984       PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53985  
53986       RETURN
53987       END
53988  
53989 C*********************************************************************
53990  
53991 C...PYX2XG
53992 C...Calculates the decay rate for ino -> ino + gauge boson.
53993  
53994       FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53995  
53996 C...Double precision and integer declarations.
53997       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53998       IMPLICIT INTEGER(I-N)
53999       INTEGER PYK,PYCHGE,PYCOMP
54000  
54001 C...Local variables.
54002       DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
54003       DOUBLE PRECISION XL,PYLAMF,C1
54004       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
54005  
54006       XMI2=XM1**2
54007       XMI3=ABS(XM1**3)
54008       XMJ2=XM2**2
54009       XMV2=XM3**2
54010       XL=PYLAMF(XMI2,XMJ2,XMV2)
54011       PYX2XG=C1/8D0/XMI3*SQRT(XL)
54012      &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
54013      &12D0*GLR*XM1*XM2*XMV2)
54014  
54015       RETURN
54016       END
54017  
54018 C*********************************************************************
54019  
54020 C...PYX2XH
54021 C...Calculates the decay rate for ino -> ino + H.
54022  
54023       FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
54024  
54025 C...Double precision and integer declarations.
54026       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54027       IMPLICIT INTEGER(I-N)
54028       INTEGER PYK,PYCHGE,PYCOMP
54029  
54030 C...Local variables.
54031       DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
54032       DOUBLE PRECISION XL,PYLAMF,C1
54033       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
54034  
54035       XMI2=XM1**2
54036       XMI3=ABS(XM1**3)
54037       XMJ2=XM2**2
54038       XMV2=XM3**2
54039       XL=PYLAMF(XMI2,XMJ2,XMV2)
54040       PYX2XH=C1/8D0/XMI3*SQRT(XL)
54041      &*(GX2*(XMI2+XMJ2-XMV2)+
54042      &4D0*GLR*XM1*XM2)
54043  
54044       RETURN
54045       END
54046  
54047 C*********************************************************************
54048  
54049 C...PYHEXT
54050 C...Calculates the non-standard decay modes of the Higgs boson.
54051 C...
54052 C...Author:  Stephen Mrenna
54053 C...Last Update:  April 2001
54054 C......Allow complex values for Z,U, and V
54055  
54056       SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
54057  
54058 C...Double precision and integer declarations.
54059       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54060       IMPLICIT INTEGER(I-N)
54061       INTEGER PYK,PYCHGE,PYCOMP
54062 C...Parameter statement to help give large particle numbers.
54063       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54064      &KEXCIT=4000000,KDIMEN=5000000)
54065 C...Commonblocks.
54066       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54067       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54068       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54069       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54070       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54071      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54072       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
54073  
54074 C...Local variables.
54075       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
54076       COMPLEX*16 QIJ,RIJ,F21K,F12K
54077       INTEGER KFIN
54078       DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
54079       DOUBLE PRECISION XMI2,XMI3,XMJ2
54080       DOUBLE PRECISION PYLAMF,XL,CF,EI
54081       INTEGER IDU,IFL
54082       DOUBLE PRECISION TANW,XW,AEM,C1,AS
54083       DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
54084       DOUBLE PRECISION XLAM(0:400)
54085       INTEGER IDLAM(400,3)
54086       INTEGER LKNT,IH,J,IJ,I,IKNT,IK
54087       INTEGER ITH(4)
54088       INTEGER KFNCHI(4),KFCCHI(2)
54089       DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
54090       DOUBLE PRECISION SR2
54091       DOUBLE PRECISION BETA,ALFA
54092       DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
54093       DOUBLE PRECISION PYALEM
54094       DOUBLE PRECISION AL,AR,ALR
54095       DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
54096       DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
54097       DOUBLE PRECISION XMJL,XMJR,XM1,XM2
54098       DATA ITH/25,35,36,37/
54099       DATA ETAH/1D0,1D0,-1D0/
54100       DATA SR2/1.4142136D0/
54101       DATA KFNCHI/1000022,1000023,1000025,1000035/
54102       DATA KFCCHI/1000024,1000037/
54103  
54104 C...COUNT THE NUMBER OF DECAY MODES
54105       LKNT=IKNT
54106  
54107       XMW=PMAS(24,1)
54108       XMW2=XMW**2
54109       XMZ=PMAS(23,1)
54110       XW=PARU(102)
54111       TANW = SQRT(XW/(1D0-XW))
54112       CW=SQRT(1D0-XW)
54113  
54114 C...1 - 4 DEPENDING ON Higgs species.
54115       IH=1
54116       IF(KFIN.EQ.ITH(2)) IH=2
54117       IF(KFIN.EQ.ITH(3)) IH=3
54118       IF(KFIN.EQ.ITH(4)) IH=4
54119  
54120       XMI=PMAS(KFIN,1)
54121       XMI2=XMI**2
54122       AXMI=ABS(XMI)
54123       AEM=PYALEM(XMI2)
54124       C1=AEM/XW
54125       XMI3=ABS(XMI**3)
54126  
54127       TANB=RMSS(5)
54128       BETA=ATAN(TANB)
54129       CBETA=COS(BETA)
54130       SBETA=TANB*CBETA
54131       ALFA=RMSS(18)
54132       COSA=COS(ALFA)
54133       SINA=SIN(ALFA)
54134       ATRIT=RMSS(16)
54135       ATRIB=RMSS(15)
54136       ATRIL=RMSS(17)
54137       XMUZ=-RMSS(4)
54138  
54139       DO 110 I=1,4
54140         DO 100 J=1,4
54141           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
54142   100   CONTINUE
54143   110 CONTINUE
54144       DO 130 I=1,2
54145         DO 120 J=1,2
54146            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
54147            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
54148   120   CONTINUE
54149   130 CONTINUE
54150  
54151  
54152       IF(IH.EQ.4) GOTO 220
54153  
54154 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
54155 C...H0_K -> CHI0_I + CHI0_J
54156       EH(2)=SINA
54157       EH(1)=COSA
54158       EH(3)=CBETA
54159       DH(2)=COSA
54160       DH(1)=-SINA
54161       DH(3)=SBETA
54162       DO 150 IJ=1,4
54163         XMJ=SMZ(IJ)
54164         AXMJ=ABS(XMJ)
54165         DO 140 IK=1,IJ
54166           XMK=SMZ(IK)
54167           AXMK=ABS(XMK)
54168           IF(AXMI.GE.AXMJ+AXMK) THEN
54169             LKNT=LKNT+1
54170             QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
54171      &      ZMIXC(IJ,3)*ZMIXC(IK,2)-
54172      &      TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
54173      &      ZMIXC(IJ,3)*ZMIXC(IK,1))
54174             RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
54175      &      ZMIXC(IJ,4)*ZMIXC(IK,2)-
54176      &      TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
54177      &      ZMIXC(IJ,4)*ZMIXC(IK,1))
54178             F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
54179             F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
54180 C...SIGN OF MASSES I,J
54181             XML=XMK*ETAH(IH)
54182             GX2=ABS(F12K)**2+ABS(F21K)**2
54183             GLR=DBLE(F12K*DCONJG(F21K))
54184             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54185             IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
54186             IDLAM(LKNT,1)=KFNCHI(IJ)
54187             IDLAM(LKNT,2)=KFNCHI(IK)
54188             IDLAM(LKNT,3)=0
54189           ENDIF
54190   140   CONTINUE
54191   150 CONTINUE
54192  
54193 C...H0_K -> CHI+_I CHI-_J
54194       DO 170 IJ=1,2
54195         XMJ=SMW(IJ)
54196         AXMJ=ABS(XMJ)
54197         DO 160 IK=1,2
54198           XMK=SMW(IK)
54199           AXMK=ABS(XMK)
54200           IF(AXMI.GE.AXMJ+AXMK) THEN
54201             LKNT=LKNT+1
54202             OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
54203      &      VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
54204             ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
54205      &      VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
54206             GX2=ABS(OLPP)**2+ABS(ORPP)**2
54207             GLR=DBLE(OLPP*DCONJG(ORPP))
54208             XML=XMK*ETAH(IH)
54209             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54210             IDLAM(LKNT,1)=KFCCHI(IJ)
54211             IDLAM(LKNT,2)=-KFCCHI(IK)
54212             IDLAM(LKNT,3)=0
54213           ENDIF
54214   160   CONTINUE
54215   170 CONTINUE
54216  
54217 C...HIGGS TO SFERMION SFERMION
54218       DO 200 IFL=1,16
54219         IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
54220         IJ=KSUSY1+IFL
54221         XMJL=PMAS(PYCOMP(IJ),1)
54222         XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
54223         IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
54224           XMJ=XMJL
54225           XMJ2=XMJ**2
54226           XL=PYLAMF(XMI2,XMJ2,XMJ2)
54227           XMF=PMAS(IFL,1)
54228           EI=KCHG(IFL,1)/3D0
54229           IDU=2-MOD(IFL,2)
54230  
54231           IF(IH.EQ.1) THEN
54232             IF(IDU.EQ.1) THEN
54233               GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
54234      &        XMF**2/XMW*SINA/CBETA
54235               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
54236      &        XMF**2/XMW*SINA/CBETA
54237               IF(IFL.EQ.5) THEN
54238                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54239      &          ATRIB*SINA)
54240               ELSEIF(IFL.EQ.15) THEN
54241                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54242      &          ATRIL*SINA)
54243               ELSE
54244                 GHLR=0D0
54245               ENDIF
54246             ELSE
54247               GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
54248      &        XMF**2/XMW*COSA/SBETA
54249               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
54250      &        XMF**2/XMW*COSA/SBETA
54251               IF(IFL.EQ.6) THEN
54252                 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
54253      &          ATRIT*COSA)
54254               ELSE
54255                 GHLR=0D0
54256               ENDIF
54257             ENDIF
54258  
54259           ELSEIF(IH.EQ.2) THEN
54260             IF(IDU.EQ.1) THEN
54261               GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
54262      &        XMF**2/XMW*COSA/CBETA
54263               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54264      &        XMF**2/XMW*COSA/CBETA
54265               IF(IFL.EQ.5) THEN
54266                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54267      &          ATRIB*COSA)
54268               ELSEIF(IFL.EQ.15) THEN
54269                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54270      &          ATRIL*COSA)
54271               ELSE
54272                 GHLR=0D0
54273               ENDIF
54274             ELSE
54275               GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
54276      &        XMF**2/XMW*SINA/SBETA
54277               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54278      &        XMF**2/XMW*SINA/SBETA
54279               IF(IFL.EQ.6) THEN
54280                 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
54281      &          ATRIT*SINA)
54282               ELSE
54283                 GHLR=0D0
54284               ENDIF
54285             ENDIF
54286  
54287           ELSEIF(IH.EQ.3) THEN
54288             GHLL=0D0
54289             GHRR=0D0
54290             GHLR=0D0
54291             IF(IDU.EQ.1) THEN
54292               IF(IFL.EQ.5) THEN
54293                 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
54294               ELSEIF(IFL.EQ.15) THEN
54295                 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
54296               ENDIF
54297             ELSE
54298               IF(IFL.EQ.6) THEN
54299                 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
54300               ENDIF
54301             ENDIF
54302           ENDIF
54303           IF(IH.EQ.3) GOTO 180
54304  
54305           AL=SFMIX(IFL,1)**2
54306           AR=SFMIX(IFL,2)**2
54307           ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
54308           IF(IFL.LE.6) THEN
54309             CF=3D0
54310           ELSE
54311             CF=1D0
54312           ENDIF
54313  
54314           IF(AXMI.GE.2D0*XMJ) THEN
54315             LKNT=LKNT+1
54316             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54317      &      (GHLL*AL+GHRR*AR
54318      &      +2D0*GHLR*ALR)**2
54319             IDLAM(LKNT,1)=IJ
54320             IDLAM(LKNT,2)=-IJ
54321             IDLAM(LKNT,3)=0
54322           ENDIF
54323  
54324           IF(AXMI.GE.2D0*XMJR) THEN
54325             LKNT=LKNT+1
54326             AL=SFMIX(IFL,3)**2
54327             AR=SFMIX(IFL,4)**2
54328             ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
54329             XMJ=XMJR
54330             XMJ2=XMJ**2
54331             XL=PYLAMF(XMI2,XMJ2,XMJ2)
54332             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54333      &      (GHLL*AL+GHRR*AR
54334      &      +2D0*GHLR*ALR)**2
54335             IDLAM(LKNT,1)=IJ+KSUSY1
54336             IDLAM(LKNT,2)=-(IJ+KSUSY1)
54337             IDLAM(LKNT,3)=0
54338           ENDIF
54339   180     CONTINUE
54340  
54341           IF(AXMI.GE.XMJL+XMJR) THEN
54342             LKNT=LKNT+1
54343             AL=SFMIX(IFL,1)*SFMIX(IFL,3)
54344             AR=SFMIX(IFL,2)*SFMIX(IFL,4)
54345             ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
54346             XMJ=XMJR
54347             XMJ2=XMJ**2
54348             XL=PYLAMF(XMI2,XMJ2,XMJL**2)
54349             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54350      &      (GHLL*AL+GHRR*AR)**2
54351             IDLAM(LKNT,1)=IJ
54352             IDLAM(LKNT,2)=-(IJ+KSUSY1)
54353             IDLAM(LKNT,3)=0
54354             LKNT=LKNT+1
54355             IDLAM(LKNT,1)=-IJ
54356             IDLAM(LKNT,2)=IJ+KSUSY1
54357             IDLAM(LKNT,3)=0
54358             XLAM(LKNT)=XLAM(LKNT-1)
54359           ENDIF
54360         ENDIF
54361   190   CONTINUE
54362   200 CONTINUE
54363   210 CONTINUE
54364  
54365       GOTO 270
54366   220 CONTINUE
54367  
54368 C...H+ -> CHI+_I + CHI0_J
54369       DO 240 IJ=1,4
54370         XMJ=SMZ(IJ)
54371         AXMJ=ABS(XMJ)
54372         XMJ2=XMJ**2
54373         DO 230 IK=1,2
54374           XMK=SMW(IK)
54375           AXMK=ABS(XMK)
54376           IF(AXMI.GE.AXMJ+AXMK) THEN
54377             LKNT=LKNT+1
54378             OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
54379      &      ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
54380             ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
54381      &      (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
54382             GX2=ABS(OLPP)**2+ABS(ORPP)**2
54383             GLR=DBLE(OLPP*DCONJG(ORPP))
54384             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
54385             IDLAM(LKNT,1)=KFNCHI(IJ)
54386             IDLAM(LKNT,2)=KFCCHI(IK)
54387             IDLAM(LKNT,3)=0
54388           ENDIF
54389   230   CONTINUE
54390   240 CONTINUE
54391  
54392       GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
54393       GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
54394       AL=0D0
54395       AR=0D0
54396       CF=3D0
54397  
54398 C...H+ -> T_1 B_1~
54399       XM1=PMAS(PYCOMP(KSUSY1+6),1)
54400       XM2=PMAS(PYCOMP(KSUSY1+5),1)
54401       IF(XMI.GE.XM1+XM2) THEN
54402         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54403         LKNT=LKNT+1
54404         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54405      &  (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
54406         IDLAM(LKNT,1)=KSUSY1+6
54407         IDLAM(LKNT,2)=-(KSUSY1+5)
54408         IDLAM(LKNT,3)=0
54409       ENDIF
54410  
54411 C...H+ -> T_2 B_1~
54412       XM1=PMAS(PYCOMP(KSUSY2+6),1)
54413       XM2=PMAS(PYCOMP(KSUSY1+5),1)
54414       IF(XMI.GE.XM1+XM2) THEN
54415         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54416         LKNT=LKNT+1
54417         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54418      &  (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
54419         IDLAM(LKNT,1)=KSUSY2+6
54420         IDLAM(LKNT,2)=-(KSUSY1+5)
54421         IDLAM(LKNT,3)=0
54422       ENDIF
54423  
54424 C...H+ -> T_1 B_2~
54425       XM1=PMAS(PYCOMP(KSUSY1+6),1)
54426       XM2=PMAS(PYCOMP(KSUSY2+5),1)
54427       IF(XMI.GE.XM1+XM2) THEN
54428         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54429         LKNT=LKNT+1
54430         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54431      &  (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
54432         IDLAM(LKNT,1)=KSUSY1+6
54433         IDLAM(LKNT,2)=-(KSUSY2+5)
54434         IDLAM(LKNT,3)=0
54435       ENDIF
54436  
54437 C...H+ -> T_2 B_2~
54438       XM1=PMAS(PYCOMP(KSUSY2+6),1)
54439       XM2=PMAS(PYCOMP(KSUSY2+5),1)
54440       IF(XMI.GE.XM1+XM2) THEN
54441         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54442         LKNT=LKNT+1
54443         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54444      &  (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
54445         IDLAM(LKNT,1)=KSUSY2+6
54446         IDLAM(LKNT,2)=-(KSUSY2+5)
54447         IDLAM(LKNT,3)=0
54448       ENDIF
54449  
54450 C...H+ -> UL DL~
54451       GL=-XMW/SR2*SIN(2D0*BETA)
54452       DO 250 IJ=1,3,2
54453         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54454         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54455         IF(XMI.GE.XM1+XM2) THEN
54456           XL=PYLAMF(XMI2,XM1**2,XM2**2)
54457           LKNT=LKNT+1
54458           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54459           IDLAM(LKNT,1)=-(KSUSY1+IJ)
54460           IDLAM(LKNT,2)=KSUSY1+IJ+1
54461           IDLAM(LKNT,3)=0
54462         ENDIF
54463   250 CONTINUE
54464  
54465 C...H+ -> EL~ NUL
54466       CF=1D0
54467       DO 260 IJ=11,13,2
54468         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54469         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54470         IF(XMI.GE.XM1+XM2) THEN
54471           XL=PYLAMF(XMI2,XM1**2,XM2**2)
54472           LKNT=LKNT+1
54473           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54474           IDLAM(LKNT,1)=-(KSUSY1+IJ)
54475           IDLAM(LKNT,2)=KSUSY1+IJ+1
54476           IDLAM(LKNT,3)=0
54477         ENDIF
54478   260 CONTINUE
54479  
54480 C...H+ -> TAU1 NUTAUL
54481       XM1=PMAS(PYCOMP(KSUSY1+15),1)
54482       XM2=PMAS(PYCOMP(KSUSY1+16),1)
54483       IF(XMI.GE.XM1+XM2) THEN
54484         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54485         LKNT=LKNT+1
54486         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
54487         IDLAM(LKNT,1)=-(KSUSY1+15)
54488         IDLAM(LKNT,2)= KSUSY1+16
54489         IDLAM(LKNT,3)=0
54490       ENDIF
54491  
54492 C...H+ -> TAU2 NUTAUL
54493       XM1=PMAS(PYCOMP(KSUSY2+15),1)
54494       XM2=PMAS(PYCOMP(KSUSY1+16),1)
54495       IF(XMI.GE.XM1+XM2) THEN
54496         XL=PYLAMF(XMI2,XM1**2,XM2**2)
54497         LKNT=LKNT+1
54498         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
54499         IDLAM(LKNT,1)=-(KSUSY2+15)
54500         IDLAM(LKNT,2)= KSUSY1+16
54501         IDLAM(LKNT,3)=0
54502       ENDIF
54503  
54504   270 CONTINUE
54505       IKNT=LKNT
54506       XLAM(0)=0D0
54507       DO 280 I=1,IKNT
54508         IF(XLAM(I).LE.0D0) XLAM(I)=0D0
54509         XLAM(0)=XLAM(0)+XLAM(I)
54510   280 CONTINUE
54511       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
54512  
54513       RETURN
54514       END
54515  
54516 C*********************************************************************
54517  
54518 C...PYH2XX
54519 C...Calculates the decay rate for a Higgs to an ino pair.
54520  
54521       FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
54522  
54523 C...Double precision and integer declarations.
54524       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54525       IMPLICIT INTEGER(I-N)
54526       INTEGER PYK,PYCHGE,PYCOMP
54527 C...Commonblocks.
54528       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54529       SAVE /PYDAT1/
54530  
54531 C...Local variables.
54532       DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
54533       DOUBLE PRECISION XL,PYLAMF,C1
54534       DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
54535  
54536       XMI2=XM1**2
54537       XMI3=ABS(XM1**3)
54538       XMJ2=XM2**2
54539       XMK2=XM3**2
54540       XL=PYLAMF(XMI2,XMJ2,XMK2)
54541       PYH2XX=C1/4D0/XMI3*SQRT(XL)
54542      &*(GX2*(XMI2-XMJ2-XMK2)-
54543      &4D0*GLR*XM3*XM2)
54544       IF(PYH2XX.LT.0D0) PYH2XX=0D0
54545  
54546       RETURN
54547       END
54548  
54549 C*********************************************************************
54550  
54551 C...PYGAUS
54552 C...Integration by adaptive Gaussian quadrature.
54553 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54554  
54555       FUNCTION PYGAUS(F, A, B, EPS)
54556  
54557 C...Double precision and integer declarations.
54558       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54559       IMPLICIT INTEGER(I-N)
54560       INTEGER PYK,PYCHGE,PYCOMP
54561  
54562 C...Local declarations.
54563       EXTERNAL F
54564       DOUBLE PRECISION F,W(12), X(12)
54565       DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54566       DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54567       DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54568       DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54569       DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54570       DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54571       DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54572       DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54573       DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54574       DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54575       DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54576       DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54577  
54578 C...The Gaussian quadrature algorithm.
54579       H = 0D0
54580       IF(B .EQ. A) GOTO 140
54581       CONST = 5D-3 / ABS(B-A)
54582       BB = A
54583   100 CONTINUE
54584       AA = BB
54585       BB = B
54586   110 CONTINUE
54587       C1 = 0.5D0*(BB+AA)
54588       C2 = 0.5D0*(BB-AA)
54589       S8 = 0D0
54590       DO 120 I = 1, 4
54591         U = C2*X(I)
54592         S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54593   120 CONTINUE
54594       S16 = 0D0
54595       DO 130 I = 5, 12
54596         U = C2*X(I)
54597         S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54598   130 CONTINUE
54599       S16 = C2*S16
54600       IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54601         H = H + S16
54602         IF(BB .NE. B) GOTO 100
54603       ELSE
54604         BB = C1
54605         IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54606         H = 0D0
54607         CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
54608         GOTO 140
54609       ENDIF
54610   140 CONTINUE
54611       PYGAUS = H
54612  
54613       RETURN
54614       END
54615  
54616 C*********************************************************************
54617  
54618 C...PYGAU2
54619 C...Integration by adaptive Gaussian quadrature.
54620 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54621 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
54622  
54623       FUNCTION PYGAU2(F, A, B, EPS)
54624  
54625 C...Double precision and integer declarations.
54626       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54627       IMPLICIT INTEGER(I-N)
54628       INTEGER PYK,PYCHGE,PYCOMP
54629  
54630 C...Local declarations.
54631       EXTERNAL F
54632       DOUBLE PRECISION F,W(12), X(12)
54633       DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54634       DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54635       DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54636       DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54637       DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54638       DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54639       DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54640       DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54641       DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54642       DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54643       DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54644       DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54645  
54646 C...The Gaussian quadrature algorithm.
54647       H = 0D0
54648       IF(B .EQ. A) GOTO 140
54649       CONST = 5D-3 / ABS(B-A)
54650       BB = A
54651   100 CONTINUE
54652       AA = BB
54653       BB = B
54654   110 CONTINUE
54655       C1 = 0.5D0*(BB+AA)
54656       C2 = 0.5D0*(BB-AA)
54657       S8 = 0D0
54658       DO 120 I = 1, 4
54659         U = C2*X(I)
54660         S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54661   120 CONTINUE
54662       S16 = 0D0
54663       DO 130 I = 5, 12
54664         U = C2*X(I)
54665         S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54666   130 CONTINUE
54667       S16 = C2*S16
54668       IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54669         H = H + S16
54670         IF(BB .NE. B) GOTO 100
54671       ELSE
54672         BB = C1
54673         IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54674         H = 0D0
54675         CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
54676         GOTO 140
54677       ENDIF
54678   140 CONTINUE
54679       PYGAU2 = H
54680  
54681       RETURN
54682       END
54683  
54684 C*********************************************************************
54685  
54686 C...PYSIMP
54687 C...Simpson formula for an integral.
54688  
54689       FUNCTION PYSIMP(Y,X0,X1,N)
54690  
54691 C...Double precision and integer declarations.
54692       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54693       IMPLICIT INTEGER(I-N)
54694       INTEGER PYK,PYCHGE,PYCOMP
54695  
54696 C...Local variables.
54697       DOUBLE PRECISION Y,X0,X1,H,S
54698       DIMENSION Y(0:N)
54699  
54700       S=0D0
54701       H=(X1-X0)/N
54702       DO 100 I=0,N-2,2
54703         S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
54704   100 CONTINUE
54705       PYSIMP=S*H/3D0
54706  
54707       RETURN
54708       END
54709  
54710 C*********************************************************************
54711  
54712 C...PYLAMF
54713 C...The standard lambda function.
54714  
54715       FUNCTION PYLAMF(X,Y,Z)
54716  
54717 C...Double precision and integer declarations.
54718       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54719       IMPLICIT INTEGER(I-N)
54720       INTEGER PYK,PYCHGE,PYCOMP
54721  
54722 C...Local variables.
54723       DOUBLE PRECISION PYLAMF,X,Y,Z
54724  
54725       PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
54726       IF(PYLAMF.LT.0D0) PYLAMF=0D0
54727  
54728       RETURN
54729       END
54730  
54731 C*********************************************************************
54732  
54733 C...PYTBDY
54734 C...Generates 3-body decays of gauginos.
54735  
54736       SUBROUTINE PYTBDY(IDIN)
54737  
54738 C...Double precision and integer declarations.
54739       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54740       IMPLICIT INTEGER(I-N)
54741       INTEGER PYK,PYCHGE,PYCOMP
54742 C...Parameter statement to help give large particle numbers.
54743       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54744      &KEXCIT=4000000,KDIMEN=5000000)
54745 C...Commonblocks.
54746       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54747       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54748       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54749 C     COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54750       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54751       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54752      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54753 C     SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
54754       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/
54755  
54756 C...Local variables.
54757       DOUBLE PRECISION XM(5)
54758       COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
54759       COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
54760       COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
54761       DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
54762       DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
54763       DOUBLE PRECISION CPHI1,SPHI1
54764       DOUBLE PRECISION S23DEL,EPS
54765       DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
54766       PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
54767       DOUBLE PRECISION F1,F2,X0,X1,X2,X3
54768       INTEGER INOID(4)
54769       DATA INOID/22,23,25,35/
54770       DATA EPS/1D-6/
54771  
54772       ID=IDIN
54773       ISKIP=1
54774       XM(1)=P(N+1,5)
54775       XM(2)=P(N+2,5)
54776       XM(3)=P(N+3,5)
54777       XM(5)=P(ID,5)
54778  
54779 C...GENERATE S12
54780       S12MIN=(XM(1)+XM(2))**2
54781       S12MAX=(XM(5)-XM(3))**2
54782       YJACO1=S12MAX-S12MIN
54783  
54784 C...Initialize some parameters
54785       XW=PARU(102)
54786       XW1=1D0-XW
54787       TANW=SQRT(XW/XW1)
54788       IZID1=0
54789       IWID1=0
54790       IZID2=0
54791       IWID2=0
54792 
54793       IA=K(N+2,2)
54794       JA=K(N+3,2)
54795 
54796 C...Mrenna: check that we are indeed decaying a SUSY particle
54797       IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
54798       
54799       ELSE
54800         DO 100 I1=1,4
54801           IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
54802           IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
54803  100    CONTINUE
54804         IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
54805         IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
54806         IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
54807         IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
54808         ZM12=XM(5)**2
54809         ZM22=XM(1)**2
54810         EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
54811         T3I=SIGN(1D0,EI+1D-6)/2D0
54812       ENDIF
54813 
54814       IF(MSTP(47).EQ.0) THEN
54815         ISKIP=0
54816       ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
54817         ISKIP=0
54818       ELSEIF(IZID1*IZID2.NE.0) THEN
54819         SQMZ=PMAS(23,1)**2
54820         GMMZ=PMAS(23,1)*PMAS(23,2)
54821         DO 110 I=1,4
54822           ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
54823           ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54824   110   CONTINUE
54825         OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
54826      &  ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
54827         ORPP=DCONJG(OLPP)
54828         XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54829         XLR2=XLL2
54830         XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
54831         XRL2=XRR2
54832         GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
54833      &  DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
54834         GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
54835         XM1M2=SMZ(IZID1)*SMZ(IZID2)
54836         QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
54837         QLLU=-GLIJ
54838         QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
54839         QLRT=DCONJG(GLIJ)
54840         QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54841         QRLT=GRIJ
54842         QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54843         QRRU=-DCONJG(GRIJ)
54844       ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54845         IF(IZID1.NE.0) THEN
54846           XM1M2=SMZ(IZID1)*SMW(IWID2)
54847           IZID1=IWID2
54848           IZID2=IZID1
54849         ELSE
54850           XM1M2=SMZ(IZID2)*SMW(IWID1)
54851           IZID1=IWID1
54852         ENDIF
54853         RT2I = 1D0/SQRT(2D0)
54854         SQMZ=PMAS(24,1)**2
54855         GMMZ=PMAS(24,1)*PMAS(24,2)
54856         DO 120 I=1,2
54857           VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54858           UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54859   120   CONTINUE
54860         DO 130 I=1,4
54861           ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54862   130   CONTINUE
54863         QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54864      &  DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54865         QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54866      &  ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54867         EJ=KCHG(IABS(JA),1)/3D0
54868         T3J=SIGN(1D0,EJ+1D-6)/2D0
54869         QRLS=DCMPLX(0D0,0D0)
54870         QRLT=QRLS
54871         QRRS=QRLS
54872         QRRU=QRLS
54873         XRR2=1D6**2
54874         XRL2=XRR2
54875         XLR2  = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54876         XLL2  = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54877         IF(MOD(IA,2).EQ.0) THEN
54878           QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54879      &    TANW+ZMIXC(IZID2,2)*T3I)
54880           QLRT=-DCONJG(UMIXC(IZID1,1))*(
54881      &    ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54882         ELSE
54883           QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54884      &    TANW+ZMIXC(IZID2,2)*T3J)
54885           QLRT=-DCONJG(UMIXC(IZID1,1))*(
54886      &    ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54887         ENDIF
54888       ELSEIF(IWID1*IWID2.NE.0) THEN
54889         IZID1=IWID1
54890         IZID2=IWID2
54891         XM1M2=SMW(IWID1)*SMW(IWID2)
54892         SQMZ=PMAS(23,1)**2
54893         GMMZ=PMAS(23,1)*PMAS(23,2)
54894         DO 140 I=1,2
54895           VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54896           UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54897           VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54898           UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54899   140   CONTINUE
54900         OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54901      &  VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54902         ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54903      &  UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54904         QRLS=-DCMPLX(EI/XW1)*ORPP
54905         QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54906         QRRS=-DCMPLX(EI/XW1)*OLPP
54907         QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54908         IF(MOD(IA,2).EQ.0) THEN
54909           XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54910           QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54911         ELSE
54912           XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54913           QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54914         ENDIF
54915       ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54916      &THEN
54917         ISKIP=0
54918       ELSE
54919         ISKIP=0
54920       ENDIF
54921  
54922       IF(ISKIP.NE.0) THEN
54923         WTMAX=0D0
54924         DO 160 KT=1,100
54925           S12=S12MIN+YJACO1*(KT-1)/99
54926           S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54927      &    *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54928           S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54929      &    -(2D0*XM(1)*XM(2))**2
54930           S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54931      &    -(2D0*XM(3)*XM(5))**2
54932           S23DF1=S23DF1*EPS
54933           S23DF2=S23DF2*EPS
54934           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54935           S23DEL=S23DEL/EPS
54936           S23MIN=S23AVE-S23DEL
54937           S23MAX=S23AVE+S23DEL
54938           YJACO2=S23MAX-S23MIN
54939           TH=S12
54940           DO 150 KS=1,100
54941             S23=S23MIN+YJACO2*(KS-1)/99
54942             SH=S23
54943             UH=ZM12+ZM22-SH-TH
54944             WU2 = (UH-ZM12)*(UH-ZM22)
54945             WT2 = (TH-ZM12)*(TH-ZM22)
54946             WS2 = XM1M2*SH
54947             PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54948             PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54949             QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54950             QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54951             QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54952             QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54953             WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54954      &      (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54955      &      2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54956             IF(WT0.GT.WTMAX) WTMAX=WT0
54957   150     CONTINUE
54958   160   CONTINUE
54959  
54960         WTMAX=WTMAX*1.05D0
54961       ENDIF
54962  
54963 C...FIND S12*
54964       AX=S12MIN
54965       CX=S12MAX
54966       BX=S12MIN+0.5D0*YJACO1
54967       X0=AX
54968       X3=CX
54969       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54970         X1=BX
54971         X2=BX+C*(CX-BX)
54972       ELSE
54973         X2=BX
54974         X1=BX-C*(BX-AX)
54975       ENDIF
54976  
54977 C...SOLVE FOR F1 AND F2
54978       S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54979      &-(2D0*XM(1)*XM(2))**2
54980       S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54981      &-(2D0*XM(3)*XM(5))**2
54982       S23DF1=S23DF1*EPS
54983       S23DF2=S23DF2*EPS
54984       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54985       F1=-2D0*S23DEL/EPS
54986       S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54987      &-(2D0*XM(1)*XM(2))**2
54988       S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54989      &-(2D0*XM(3)*XM(5))**2
54990       S23DF1=S23DF1*EPS
54991       S23DF2=S23DF2*EPS
54992       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54993       F2=-2D0*S23DEL/EPS
54994  
54995   170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54996 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54997         IF(F2.LE.F1)THEN
54998           X0=X1
54999           X1=X2
55000           X2=R*X1+C*X3
55001           F1=F2
55002           S23DF1=(X2-XM(2)**2-XM(1)**2)**2
55003      &    -(2D0*XM(1)*XM(2))**2
55004           S23DF2=(X2-XM(3)**2-XM(5)**2)**2
55005      &    -(2D0*XM(3)*XM(5))**2
55006           S23DF1=S23DF1*EPS
55007           S23DF2=S23DF2*EPS
55008           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
55009           F2=-2D0*S23DEL/EPS
55010         ELSE
55011           X3=X2
55012           X2=X1
55013           X1=R*X2+C*X0
55014           F2=F1
55015           S23DF1=(X1-XM(2)**2-XM(1)**2)**2
55016      &    -(2D0*XM(1)*XM(2))**2
55017           S23DF2=(X1-XM(3)**2-XM(5)**2)**2
55018      &    -(2D0*XM(3)*XM(5))**2
55019           S23DF1=S23DF1*EPS
55020           S23DF2=S23DF2*EPS
55021           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
55022           F1=-2D0*S23DEL/EPS
55023         ENDIF
55024         GOTO 170
55025       ENDIF
55026 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
55027       IF(F1.LT.F2)THEN
55028         GOLDEN=-F1
55029         XMIN=X1
55030       ELSE
55031         GOLDEN=-F2
55032         XMIN=X2
55033       ENDIF
55034  
55035       IKNT=0
55036   180 S12=S12MIN+PYR(0)*YJACO1
55037       IKNT=IKNT+1
55038 C...GENERATE S23
55039       S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
55040      &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
55041       S23DF1=(S12-XM(2)**2-XM(1)**2)**2
55042      &-(2D0*XM(1)*XM(2))**2
55043       S23DF2=(S12-XM(3)**2-XM(5)**2)**2
55044      &-(2D0*XM(3)*XM(5))**2
55045       S23DF1=S23DF1*EPS
55046       S23DF2=S23DF2*EPS
55047       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
55048       S23DEL=S23DEL/EPS
55049       S23MIN=S23AVE-S23DEL
55050       S23MAX=S23AVE+S23DEL
55051       YJACO2=S23MAX-S23MIN
55052       S23=S23MIN+PYR(0)*YJACO2
55053  
55054 C...CHECK THE SAMPLING
55055       IF(IKNT.GT.100) THEN
55056         WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
55057         GOTO 190
55058       ENDIF
55059       IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
55060  
55061       IF(ISKIP.EQ.0) GOTO 190
55062  
55063       SH=S23
55064       TH=S12
55065       UH=ZM12+ZM22-SH-TH
55066  
55067       WU2 = (UH-ZM12)*(UH-ZM22)
55068       WT2 = (TH-ZM12)*(TH-ZM22)
55069       WS2 = XM1M2*SH
55070       PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
55071       PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
55072  
55073       QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
55074       QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
55075       QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
55076       QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
55077 c      QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
55078 c      QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
55079 c     &/DCMPLX(TH-XML2)
55080 c      QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
55081 c      QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
55082 c     &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
55083       WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
55084      &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
55085      &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
55086  
55087       IF(WT.LT.PYR(0)*WTMAX) GOTO 180
55088       IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
55089  
55090   190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
55091       D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
55092       D2=XM(5)-D1-D3
55093       P1=SQRT(D1*D1-XM(1)**2)
55094       P2=SQRT(D2*D2-XM(2)**2)
55095       P3=SQRT(D3*D3-XM(3)**2)
55096       CTHE1=2D0*PYR(0)-1D0
55097       ANG1=2D0*PYR(0)*PARU(1)
55098       CPHI1=COS(ANG1)
55099       SPHI1=SIN(ANG1)
55100       ARG=1D0-CTHE1**2
55101       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55102       STHE1=SQRT(ARG)
55103       P(N+1,1)=P1*STHE1*CPHI1
55104       P(N+1,2)=P1*STHE1*SPHI1
55105       P(N+1,3)=P1*CTHE1
55106       P(N+1,4)=D1
55107  
55108 C...GET CPHI3
55109       ANG3=2D0*PYR(0)*PARU(1)
55110       CPHI3=COS(ANG3)
55111       SPHI3=SIN(ANG3)
55112       CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
55113       ARG=1D0-CTHE3**2
55114       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55115       STHE3=SQRT(ARG)
55116       P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
55117      &+P3*STHE3*SPHI3*SPHI1
55118      &+P3*CTHE3*STHE1*CPHI1
55119       P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
55120      &-P3*STHE3*SPHI3*CPHI1
55121      &+P3*CTHE3*STHE1*SPHI1
55122       P(N+3,3)=P3*STHE3*CPHI3*STHE1
55123      &+P3*CTHE3*CTHE1
55124       P(N+3,4)=D3
55125  
55126       DO 200 I=1,3
55127         P(N+2,I)=-P(N+1,I)-P(N+3,I)
55128   200 CONTINUE
55129       P(N+2,4)=D2
55130  
55131       RETURN
55132       END
55133  
55134  
55135 C*********************************************************************
55136  
55137 C...PYTECM
55138 C...Finds the s-hat dependent eigenvalues of the inverse propagator
55139 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
55140 C...phase space generation.  Extended to include techni-a meson, and
55141 C...to return the width.
55142  
55143       SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
55144  
55145 C...Double precision and integer declarations.
55146       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55147       IMPLICIT INTEGER(I-N)
55148       INTEGER PYK,PYCHGE,PYCOMP
55149 C...Parameter statement to help give large particle numbers.
55150       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55151      &KEXCIT=4000000,KDIMEN=5000000)
55152 C...Commonblocks.
55153       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55154       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55155       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55156       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
55157       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
55158  
55159 C...Local variables.
55160       DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
55161      &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
55162      &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
55163       INTEGER i,j,ierr
55164 
55165       SH=SMIN
55166       SHR=SQRT(SH)
55167       AEM=PYALEM(SH)
55168  
55169       SINW=MIN(SQRT(PARU(102)),1D0)
55170       COSW=SQRT(1D0-SINW**2)
55171       TANW=SINW/COSW
55172       CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
55173       QUPD=2D0*RTCM(2)-1D0
55174 
55175       ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
55176       FAR=SQRT(AEM/ALPRHT)
55177       FAO=FAR*QUPD
55178       FZR=FAR*CT2W
55179       FZO=-FAO*TANW
55180       FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
55181       FWR=FAR/(2D0*SINW)
55182       FWX=-FWR/RTCM(47)
55183 
55184       DO 110 I=1,5
55185         DO 100 J=1,5
55186           AT(I,J)=0D0
55187   100   CONTINUE
55188   110 CONTINUE
55189 
55190 C...NC
55191       IF(IOPT.EQ.1) THEN
55192         AR(1,1) = SH
55193         AR(2,2) = SH-PMAS(23,1)**2
55194         AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
55195         AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
55196         AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
55197         AR(1,2) = 0D0
55198         AR(2,1) = 0D0
55199         AR(1,3) = SH*FAR
55200         AR(3,1) = AR(1,3)
55201         AR(1,4) = SH*FAO
55202         AR(4,1) = AR(1,4)
55203         AR(2,3) = SH*FZR
55204         AR(3,2) = AR(2,3)
55205         AR(2,4) = SH*FZO
55206         AR(4,2) = AR(2,4)
55207         AR(3,4) = 0D0
55208         AR(4,3) = 0D0
55209         AR(2,5) = SH*FZX
55210         AR(5,2) = AR(2,5)
55211         AR(1,5) = 0D0
55212         AR(5,1) = AR(1,5)
55213         AR(3,5) = 0D0
55214         AR(5,3) = AR(3,5)
55215         AR(4,5) = 0D0
55216         AR(5,4) = AR(4,5)
55217         CALL PYWIDT(23,SH,WDTP,WDTE)
55218         AT(2,2) = WDTP(0)*SHR
55219         CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
55220         AT(3,3) = WDTP(0)*SHR
55221         CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
55222         AT(4,4) = WDTP(0)*SHR
55223         CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
55224         AT(5,5) = WDTP(0)*SHR
55225         IDIM=5
55226 C...CC
55227       ELSE
55228         AR(1,1) = SH-PMAS(24,1)**2
55229         AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
55230         AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
55231         AR(1,2) = SH*FWR
55232         AR(2,1) = AR(1,2)
55233         AR(1,3) = SH*FWX
55234         AR(3,1) = AR(1,3)
55235         AR(2,3) = 0D0
55236         AR(3,2) = 0D0
55237         CALL PYWIDT(24,SH,WDTP,WDTE)
55238         AT(1,1) = WDTP(0)*SHR
55239         CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
55240         AT(2,2) = WDTP(0)*SHR
55241         CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
55242         AT(3,3) = WDTP(0)*SHR
55243         IDIM=3
55244       ENDIF
55245       CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
55246 
55247       IMIN=1
55248       SXMN=1D20
55249       DO 120 I=1,IDIM
55250         WX(I)=SQRT(ABS(SH-WR(I)))
55251         WR(I)=ABS(WR(I))
55252         IF(WR(I).LT.SXMN) THEN
55253           SXMN=WR(I)
55254           IMIN=I
55255         ENDIF
55256   120 CONTINUE
55257       SMOU=WX(IMIN)**2
55258       WIDO=WI(IMIN)/SHR
55259 
55260       RETURN
55261       END
55262 C*********************************************************************
55263  
55264 C...PYXDIN
55265 C...Universal Extra Dimensions Model (UED)
55266 C...Initialize the xd masses and widths
55267 C...M. ELKACIMI 4/03/2006
55268 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
55269 
55270       SUBROUTINE PYXDIN
55271 
55272 C...Double precision and integer declarations.
55273       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55274       IMPLICIT INTEGER(I-N)
55275       INTEGER PYK,PYCHGE,PYCOMP
55276 C...Commonblocks.
55277       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55278       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55279       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
55280 C...UED Pythia common
55281       COMMON/PYPUED/IUED(0:99),RUED(0:99)
55282 
55283 C...SAVE statements
55284       SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
55285 
55286 C...Print out some info about the UED model
55287       WRITE(MSTU(11),7000) 
55288      &    ' ',
55289      &    '********** PYXDIN: initialization of UED ******************',
55290      &    ' ',
55291      &    'Universal Extra Dimensions (UED) switched on ',
55292      &    ' ',
55293      &    'This implementation is courtesy of',
55294      &    '       M.Elkacimi, D.Goujdami, H.Przysiezniak,  ', 
55295      &    '       see [hep-ph/0602198] (Les Houches 2005) ',
55296      &    ' ',
55297      &    'The model follows [hep-ph/0012100] (Appelquist, Cheng,   ',
55298      &    'Dobrescu), with gravity-mediated decay widths calculated in',
55299      &    '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
55300      &    'radiative corrections to the KK masses from [hep/ph0204342]',
55301      &    '(Cheng, Matchev, Schmaltz).'
55302       WRITE(MSTU(11),7000) 
55303      &    ' ',
55304      &    'SM particles can propagate into one small extra dimension  ',
55305      &    'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
55306      &    'graviton is further allowed to propagate into N = IUED(4)', 
55307      &    'large (eV^-1) extra dimensions.'
55308       WRITE(MSTU(11),7000) 
55309      &    ' ',
55310      &    'The switches and parameters for UED are:',
55311      &    '    IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
55312      &    '    IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
55313      &    '    IUED(3): (D=5) number of quark flavours',
55314      &    '    IUED(4): (D=6) number of large extra dimensions into',
55315      &    '                   which the graviton propagates',
55316      &    '    IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
55317      &    '    IUED(6): (D=1) With/without rad.corrs. (=1/0)',
55318      &    '                                                 ',
55319      &    '    RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
55320      &    '    RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
55321      &    '    RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
55322      &    '                        when IUED(5)=0',
55323      &    '    RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
55324       WRITE(MSTU(11),7000) 
55325      &    ' ',
55326      &    'N.B.: the Higgs mass is also a free parameter of the UED ',
55327      &    'model, but is set through pmas(25,1).',
55328      &    ' '
55329 
55330 C...Hardcoded switch, required by current implementation     
55331       CALL PYGIVE('MSTP(42)=0')
55332 
55333 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
55334       IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
55335 
55336 C...Calculated the radiative corrections to the KK particle masses
55337       CALL PYUEDC
55338 
55339 C...Initialize the graviton mass
55340 C...only if the KK particles decays gravitationally
55341       IF(IUED(2).EQ.1) CALL PYGRAM(0)
55342 
55343       WRITE(MSTU(11),7000) 
55344      &    '********** PYXDIN: UED initialization completed  ***********'
55345 
55346 C...Format to use for comments
55347  7000 FORMAT(' * ',A)
55348 
55349       RETURN
55350       END
55351 C*********************************************************************
55352  
55353 C...PYUEDC
55354 C...Auxiliary to PYXDIN
55355 C...Mass kk states radiative corrections 
55356 C...Radiative corrections are included (hep/ph0204342)
55357 
55358       SUBROUTINE PYUEDC
55359 
55360 C...Double precision and integer declarations.
55361       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55362       IMPLICIT INTEGER(I-N)
55363       INTEGER PYK,PYCHGE,PYCOMP
55364 
55365       PARAMETER(KKPART=25,KKFLA=450)
55366 
55367 C...UED Pythia common
55368       COMMON/PYPUED/IUED(0:99),RUED(0:99)
55369 C...Pythia common: particles properties
55370       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)      
55371 C...Parameters.
55372       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55373 C...Decay information.
55374       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55375 C...Resonance width and secondary decay treatment.
55376       COMMON/PYINT4/MWID(500),WIDS(500,5)
55377       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55378 
55379 C...Local variables
55380       DOUBLE PRECISION PI,QUP,QDW
55381       DOUBLE PRECISION WDTP,WDTE
55382       DIMENSION WDTP(0:400),WDTE(0:400,0:5)
55383       DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
55384       DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
55385       DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
55386       DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
55387       DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
55388       DOUBLE PRECISION SWW1,CWW1
55389       DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
55390       DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
55391       DOUBLE PRECISION SW21,CW21,SW021,CW021
55392       COMMON/SW1/SW021,CW021
55393 C...UED related declarations:
55394 C...equivalences between ordered particles (451->475)
55395 C...and UED particle code (5 000 000 + id)
55396       DIMENSION IUEDEQ(475)
55397       DATA (IUEDEQ(I),I=451,475)/
55398 C...Singlet quarks      
55399      & 6100001,6100002,6100003,6100004,6100005,6100006,
55400 C...Doublet quarks
55401      & 5100001,5100002,5100003,5100004,5100005,5100006, 
55402 C...Singlet leptons
55403      & 6100011,6100013,6100015,                         
55404 C...Doublet leptons
55405      & 5100012,5100011,5100014,5100013,5100016,5100015,
55406 C...Gauge boson KK excitations
55407      & 5100021,5100022,5100023,5100024/                 
55408 
55409 C...N.B. rinv=rued(1)
55410       IF(RUED(1).LE.0.)THEN
55411          WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
55412          WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
55413          RETURN
55414       ENDIF
55415 
55416       PI=DACOS(-1.D0)
55417       RMZ  = PMAS(23,1)
55418       RMZ2 = RMZ**2
55419       RMW  = PMAS(24,1)
55420       RMW2 = RMW**2
55421       ALPHEM = PARU(101)
55422       QUP = 2./3.
55423       QDW = -1./3.
55424 
55425 c...qt is q-tilde, qs is q-star
55426 c...strong coupling value
55427       Q2 = RUED(1)**2
55428       ALPHS=PYALPS(Q2)
55429       
55430 c...weak mixing angle
55431       SW2=PARU(102)
55432       CW2=1D0-PARU(102)
55433       
55434 c...for the mass corrections
55435       RMKK = RUED(1)
55436       RMKK2 = RMKK**2
55437       ZETA3= 1.2
55438       
55439 C... Either fix the cutoff scale LAMUED
55440       IF(IUED(5).EQ.0)THEN
55441          LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
55442 C... or the ratio LAMUED/RINV (=product Lambda*R)
55443       ELSEIF(IUED(5).EQ.1)THEN
55444          LOGLAM = DLOG(RUED(4)**2)
55445       ELSE
55446          WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
55447          CALL PYSTOP(6000)
55448       ENDIF
55449 
55450 C...Calculate the radiative corrections for the UED KK masses
55451       IF(IUED(6).EQ.1)THEN
55452          RFACT=1.D0
55453 C...or induce a minute mass difference
55454 C...keeping the UED KK mass values nearly equal to 1/R
55455       ELSEIF(IUED(6).EQ.0)THEN
55456          RFACT=0.01D0
55457       ELSE
55458          WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
55459          CALL PYSTOP(6001)
55460       ENDIF
55461 
55462 c...Take into account only the strong interactions:
55463 
55464 c...The space bulk corrections :
55465       DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
55466 c...The boundary terms:
55467       DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
55468 
55469 c...Mass corrections for fermions are extracted from 
55470 c...Phys. Rev. D66 036005(2002)9
55471       DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
55472      .     +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
55473       DBMQU=RMKK*(3.*(ALPHS/4./PI)
55474      .     +(ALPHEM/4./PI/CW2))*LOGLAM
55475       DBMQD=RMKK*(3.*(ALPHS/4./PI)
55476      .     +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
55477       
55478       DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
55479      .     (ALPHEM/4./PI/CW2))*LOGLAM
55480       DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
55481       
55482 c...Vector boson masss matrix diagonalization
55483       DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
55484       DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
55485       DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
55486       DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
55487       
55488 c...Elements of the mass matrix
55489       A = RMZ2*SW2 + DBMB2 + DSMB2
55490       B = RMZ2*CW2 + DBMA2 + DSMA2
55491       C = RMZ2*DSQRT(SW2*CW2)
55492       SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
55493 
55494 c...Eigenvalues: corrections to X1 and Z1 masses
55495       DMB2 = (A+B-SQRDEL)/2. 
55496       DMA2 = (A+B+SQRDEL)/2. 
55497       
55498 c...Rotation angles     
55499       SWW1 = 2*C
55500       CWW1 = A-B-SQRDEL
55501 C...Weinberg angle
55502       SW21= SWW1**2/(SWW1**2 + CWW1**2)
55503       CW21= 1. - SW21
55504       
55505       SW021=SW21
55506       CW021=CW21
55507       
55508 c...Masses:
55509       RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
55510       
55511       RMDQST=RMKK+RFACT*DBMQDO
55512       RMSQUS=RMKK+RFACT*DBMQU
55513       RMSQDS=RMKK+RFACT*DBMQD
55514 
55515 C...Note: MZ mass is included in ma2
55516       RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
55517       RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
55518       RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
55519 
55520       RMLSLD=RMKK+RFACT*DBMLDO
55521       RMLSLE=RMKK+RFACT*DBMLE
55522 
55523       DO 100 IPART=1,5,2
55524         PMAS(KKFLA+IPART,1)=RMSQDS
55525  100  CONTINUE
55526       DO 110 IPART=2,6,2
55527         PMAS(KKFLA+IPART,1)=RMSQUS
55528  110  CONTINUE
55529       DO 120 IPART=7,12
55530         PMAS(KKFLA+IPART,1)=RMDQST
55531  120  CONTINUE
55532       DO 130 IPART=13,15
55533         PMAS(KKFLA+IPART,1)=RMLSLE
55534  130  CONTINUE
55535       DO 140 IPART=16,21
55536         PMAS(KKFLA+IPART,1)=RMLSLD
55537  140  CONTINUE
55538       PMAS(KKFLA+22,1)=RMGST
55539       PMAS(KKFLA+23,1)=RMPHST
55540       PMAS(KKFLA+24,1)=RMZST
55541       PMAS(KKFLA+25,1)=RMWST
55542 
55543       WRITE(MSTU(11),7000) ' PYUEDC: ',
55544      & 'UED Mass Spectrum (GeV) :'
55545       WRITE(MSTU(11),7100) '   m(d*_S,s*_S,b*_S) = ',RMSQDS
55546       WRITE(MSTU(11),7100) '   m(u*_S,c*_S,t*_S) = ',RMSQUS
55547       WRITE(MSTU(11),7100) '   m(q*_D)           = ',RMDQST
55548       WRITE(MSTU(11),7100) '   m(l*_S)           = ',RMLSLE
55549       WRITE(MSTU(11),7100) '   m(l*_D)           = ',RMLSLD
55550       WRITE(MSTU(11),7100) '   m(g*)             = ',RMGST
55551       WRITE(MSTU(11),7100) '   m(gamma*)         = ',RMPHST
55552       WRITE(MSTU(11),7100) '   m(Z*)             = ',RMZST
55553       WRITE(MSTU(11),7100) '   m(W*)             = ',RMWST
55554       WRITE(MSTU(11),7000) ' '
55555 
55556 C...Initialize widths, branching ratios and life time
55557       DO 199 IPART=1,25
55558         KC=KKFLA+IPART
55559         IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
55560           CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
55561           IF(WDTP(0).LE.0)THEN
55562              WRITE(MSTU(11),*) 
55563      +             'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
55564              WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
55565              GOTO 199
55566           ELSE
55567             DO 180 IDC=1,MDCY(KC,3)
55568               IC=IDC+MDCY(KC,2)-1
55569               IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
55570 C...Life time in cm^{-1}.  paru(3) gev^{-1} -> fm
55571                 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
55572                 BRAT(IC)=WDTP(IDC)/WDTP(0)
55573               ENDIF
55574  180        CONTINUE
55575           ENDIF
55576         ENDIF
55577  199  CONTINUE
55578 
55579 C...Format to use for comments
55580  7000 FORMAT(' * ',A)
55581  7100 FORMAT(' * ',A,F12.3)
55582 
55583       END
55584 C********************************************************************
55585 C...PYXUED
55586 C... Last change: 
55587 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
55588 C... Original version:
55589 C... M. El Kacimi
55590 C... 05/07/2005
55591 C     Universal Extra Dimensions Subprocess cross sections  
55592 C     The expressions used are from atl-com-phys-2005-003
55593 C     What is coded here is shat**2/pi * dsigma/dt = |M|**2
55594 C     For each UED subprocess, the color flow used is the same 
55595 C     as the equivalent QCD subprocess. Different configuration
55596 C     color flows are considered to have the same probability. 
55597 C
55598 C     The Xsection is calculated following ATL-PHYS-PUB-2005-003
55599 C     by G.Azuelos and P.H.Beauchemin.
55600 C
55601 C     This routine is called from pysigh.
55602 
55603       SUBROUTINE PYXUED(NCHN,SIGS)
55604 
55605 C...Double precision and integer declarations
55606       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55607       IMPLICIT INTEGER(I-N)
55608 C...
55609       INTEGER NGRDEC
55610       COMMON/DECMOD/NGRDEC
55611 C...
55612       PARAMETER(KKPART=25,KKFLA=450)
55613 C...Commonblocks
55614       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55615       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55616       COMMON/PYINT1/MINT(400),VINT(400)
55617       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
55618       COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
55619      &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
55620      &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
55621      &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
55622       SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
55623 C...UED Pythia common
55624       COMMON/PYPUED/IUED(0:99),RUED(0:99)
55625 C...Local arrays and complex variables
55626       DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
55627      + ,FAC1,XMNKK,XMUED,SIGS
55628       INTEGER NCHN
55629 
55630 C...Return if UED not switched on
55631       IF (IUED(1).LE.0) THEN 
55632         RETURN 
55633       ENDIF
55634 
55635 C...Energy scale of the parton processus
55636 C...taken equal to the mass of the final state kk
55637 c      Q2=XMNKK**2      
55638 
55639 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
55640       XMNKK=PMAS(KKFLA+23,1) 
55641 
55642 C...To compare the cross section with phys-pub-2005-03
55643 C...(no radiative corrections), 
55644 C...take xmnkk=rinv  and q2=rinv**2
55645 c++lnk
55646 C...n.b. (rinv=rued(1))
55647 c      IF(NGRDEC.EQ.1)XMNKK=RUED(0)
55648       IF(NGRDEC.EQ.1)XMNKK=RUED(1)
55649 c--lnk
55650 
55651       SHAT=VINT(44)
55652       SP=SHAT
55653       THAT=VINT(45)
55654       TP=THAT-XMNKK**2
55655       UHAT=VINT(46)
55656       UP=UHAT-XMNKK**2
55657       BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
55658       PI=DACOS(-1.D0)
55659 c++lnk
55660 c      Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
55661       Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
55662 
55663 c      IF(NGRDEC.EQ.1)Q2=RUED(0)**2
55664       IF(NGRDEC.EQ.1)Q2=RUED(1)**2
55665 c--lnk
55666 
55667 C...Strong coupling value
55668       ALPHAS=PYALPS(Q2)
55669 
55670       IF(ISUB.EQ.311)THEN
55671 C...gg --> g* g*
55672          FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
55673          XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
55674      &        24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
55675      &        +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
55676      &        12.*TP**2*UP**3+6*TP*UP**4)
55677      &        +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
55678      &        15.*TP**3*UP**3+13*TP**2*UP**4+
55679      &        6.*TP*UP**5+2.*UP**6)
55680          NCHN=NCHN+1
55681          ISIG(NCHN,1)=21
55682          ISIG(NCHN,2)=21
55683 C...Three color flow configurations (qcd g+g->g+g)
55684          XCOL=PYR(0)
55685          IF(XCOL.LE.1./3.)THEN
55686             ISIG(NCHN,3)=1
55687          ELSEIF(XCOL.LE.2./3.)THEN
55688             ISIG(NCHN,3)=2
55689          ELSE
55690             ISIG(NCHN,3)=3
55691          ENDIF
55692          SIGH(NCHN)=COMFAC*XMUED
55693       ELSEIF(ISUB.EQ.312)THEN
55694 C...q + g -> q*_D + g*, q*_S + g*
55695 C...(the two channels have the same cross section)
55696          FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
55697          XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
55698      &          5.*SP**4*UP**2+12.*SP**5*UP)
55699          XMUED=COMFAC*2.*XMUED 
55700 
55701           DO 190 I=MMINA,MMAXA
55702             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
55703             DO 180 ISDE=1,2
55704 
55705               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
55706               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
55707               NCHN=NCHN+1
55708               ISIG(NCHN,ISDE)=I
55709               ISIG(NCHN,3-ISDE)=21
55710               ISIG(NCHN,3)=1
55711               SIGH(NCHN)=XMUED
55712               IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55713   180       CONTINUE
55714   190     CONTINUE
55715 
55716       ELSEIF(ISUB.EQ.313)THEN
55717 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj 
55718 C...(the two channels have the same cross section)
55719 C...qi and qj have the same charge sign 
55720          DO 100 I=MMIN1,MMAX1
55721             IA=IABS(I)
55722             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
55723             DO 101 J=MMIN2,MMAX2
55724                JA=IABS(J)
55725                IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
55726      &           EQ.0) GOTO 101
55727                IF(J*I.LE.0)GOTO 101
55728                NCHN=NCHN+1
55729                ISIG(NCHN,1)=I
55730                ISIG(NCHN,2)=J
55731                IF(J.EQ.I)THEN
55732                   FAC1=1./72.*ALPHAS**2/(TP*UP)**2
55733                   XMUED=FAC1*
55734      &                  (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
55735      &                 +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
55736      &                 20.*TP**2*UP**2+56./3.*
55737      &                 TP*UP**3+8.*UP**4)
55738                   SIGH(NCHN)=COMFAC*2.*XMUED
55739                   ISIG(NCHN,3)=1
55740                   IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55741                ELSE
55742                   FAC1=2./9.*ALPHAS**2/TP**2
55743                   XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)     
55744                   SIGH(NCHN)=COMFAC*2.*XMUED
55745                   ISIG(NCHN,3)=1
55746                ENDIF
55747  101       CONTINUE
55748  100    CONTINUE
55749       ELSEIF(ISUB.EQ.314)THEN
55750 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar 
55751 C...(the two channels have the same cross section)
55752          NCHN=NCHN+1
55753          ISIG(NCHN,1)=21
55754          ISIG(NCHN,2)=21
55755          ISIG(NCHN,3)=INT(1.5+PYR(0))
55756 
55757          FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
55758          XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
55759      +          +4.*UP**4+4*TP**4)
55760      +          -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
55761      +          *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
55762      +          2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
55763          
55764          SIGH(NCHN)=COMFAC*XMUED 
55765 C...has been multiplied by 5: all possible quark flavors in final state
55766 
55767       ELSEIF(ISUB.EQ.315)THEN
55768 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
55769 C...(the two channels have the same cross section)
55770           DO 141 I=MMIN1,MMAX1
55771             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55772      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
55773             DO 142 J=MMIN2,MMAX2
55774                IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
55775                FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
55776                XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
55777      &              4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
55778      &              2./3.*SP**3*TP+SP**4)                  
55779                NCHN=NCHN+1
55780                ISIG(NCHN,1)=I
55781                ISIG(NCHN,2)=-I
55782                ISIG(NCHN,3)=1
55783                SIGH(NCHN)=COMFAC*2.*XMUED
55784  142        CONTINUE
55785  141      CONTINUE
55786       ELSEIF(ISUB.EQ.316)THEN
55787 C...q + qbar' -> q*_D + q*_Sbar' 
55788          FAC1=2./9.*ALPHAS**2
55789          DO 300 I=MMIN1,MMAX1
55790             IA=IABS(I)
55791             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
55792             DO 301 J=MMIN2,MMAX2
55793                JA=IABS(J)
55794                IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
55795                IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
55796                NCHN=NCHN+1
55797                ISIG(NCHN,1)=I
55798                ISIG(NCHN,2)=J
55799                ISIG(NCHN,3)=1
55800                FAC1=2./9.*ALPHAS**2/TP**2
55801                XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55802                SIGH(NCHN)=COMFAC*XMUED 
55803  301       CONTINUE
55804  300   CONTINUE
55805                
55806       ELSEIF(ISUB.EQ.317)THEN
55807 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar' 
55808 C...(the two channels have the same cross section)
55809          DO 400 I=MMIN1,MMAX1
55810             IA=IABS(I)
55811             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400     
55812             DO 401 J=MMIN1,MMAX1
55813                JA=IABS(J)
55814                IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
55815                IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
55816                NCHN=NCHN+1
55817                ISIG(NCHN,1)=I
55818                ISIG(NCHN,2)=J
55819                ISIG(NCHN,3)=1
55820                FAC1=1./18.*ALPHAS**2/TP**2
55821                XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)  
55822                SIGH(NCHN)=COMFAC*2.*XMUED 
55823  401       CONTINUE
55824  400   CONTINUE
55825       ELSEIF(ISUB.EQ.318)THEN
55826 C...q + q' -> q*_D + q*_S'
55827          DO 500 I=MMIN1,MMAX1
55828             IA=IABS(I)
55829             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500   
55830             DO 501 J=MMIN2,MMAX2
55831                JA=IABS(J)
55832                IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501 
55833                IF(J*I.LE.0)GOTO 501
55834                IF(IA.EQ.JA)THEN
55835                   NCHN=NCHN+1
55836                   ISIG(NCHN,1)=I
55837                   ISIG(NCHN,2)=J
55838                   ISIG(NCHN,3)=INT(1.5+PYR(0))
55839                   FAC1=1./36.*ALPHAS**2/(TP*UP)**2
55840                XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55841      &                 +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55842                   SIGH(NCHN)=COMFAC*XMUED              
55843                ELSE
55844                   NCHN=NCHN+1
55845                   ISIG(NCHN,1)=I
55846                   ISIG(NCHN,2)=J
55847                   ISIG(NCHN,3)=1
55848                   FAC1=1./18.*ALPHAS**2/TP**2
55849                   XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55850                   SIGH(NCHN)=COMFAC*2.*XMUED
55851                ENDIF
55852  501        CONTINUE
55853  500     CONTINUE
55854       ELSEIF(ISUB.EQ.319)THEN
55855 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55856 C...(the two channels have the same cross section)
55857           DO 741 I=MMIN1,MMAX1
55858             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55859      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55860             DO 742 J=MMIN2,MMAX2
55861                IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55862                FAC1=16./9.*ALPHAS**2*1./(SP)**2
55863                XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55864                NCHN=NCHN+1
55865                ISIG(NCHN,1)=I
55866                ISIG(NCHN,2)=-I
55867                ISIG(NCHN,3)=1
55868                SIGH(NCHN)=COMFAC*2.*XMUED
55869  742        CONTINUE
55870  741      CONTINUE   
55871        
55872       ENDIF
55873 
55874       RETURN
55875       END
55876 C*********************************************************************
55877  
55878 C...PYGRAM
55879 C...Universal Extra Dimensions Model (UED)
55880 C...Computation of the Graviton mass.
55881 
55882       SUBROUTINE PYGRAM(IN)
55883 
55884 C...Double precision and integer declarations
55885       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55886       IMPLICIT INTEGER(I-N)
55887 
55888 C...Pythia commonblocks
55889       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55890       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)      
55891 C...UED Pythia common
55892       COMMON/PYPUED/IUED(0:99),RUED(0:99)
55893 
55894 C...Local variables
55895       INTEGER KCFLA,NMAX
55896       PARAMETER(KCFLA=450,NMAX=5000)
55897       DIMENSION YVEC(5000),RESVEC(5000)
55898       COMMON/INTSAV/YSAV,YMAX,RESMAX
55899       COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55900       COMMON/KAPPA/XKAPPA
55901 
55902 C...External function (used in call to PYGAUS)
55903       EXTERNAL PYGRAW
55904 
55905 C...SAVE statements
55906       SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55907 
55908 C...Initialization
55909       NDIM=IUED(4)
55910       RINV=RUED(1)
55911       XMD=RUED(2)
55912       PI=PARU(1)
55913 
55914 C...Initialize for numerical integration
55915       XMPLNK=2.4D+18
55916       XKAPPA=DSQRT(2.D0)/XMPLNK      
55917 
55918 C...For NDIM=2, compute graviton mass distribution numerically
55919       IF(NDIM.EQ.2)THEN
55920         
55921 C...  For first event: tabulate distribution of stepwise integrals:
55922 C...  int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55923         IF(IN.EQ.0)THEN
55924           RESMAX = 0D0
55925           YMAX   = 0D0
55926           DO 100 I=1,NMAX
55927             YSAV = (I-0.5)/DBLE(NMAX)
55928             TOL       = 1D-6
55929 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55930             RESINT    = PYGAUS(PYGRAW,0D0,1D0,TOL)
55931             YVEC(I)   = YSAV
55932             RESVEC(I) = RESINT
55933 C...  Save max of distribution (for accept/reject below)
55934             IF(RESINT.GT.RESMAX)THEN
55935               RESMAX = RESINT
55936               YMAX   = YVEC(I)
55937             ENDIF
55938  100      CONTINUE
55939         ENDIF
55940         
55941 C...  Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55942         PCUJET=1D0
55943         KCGAKK=KCFLA+23
55944         XMGAMK=PMAS(KCGAKK,1)
55945         
55946 C...  Pick random graviton mass, accept according to stored integrals
55947         AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55948  110    RMG=AMMAX*PYR(0)
55949         X=RMG/XMGAMK        
55950 
55951 C...  Bin enumeration starts at 1, but make sure always in range
55952         IBIN=INT(NMAX*X)+1
55953         IBIN=MIN(IBIN,NMAX)        
55954         IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55955         
55956 C...  For NDIM=4 and 6, the analytical expression for the
55957 C...  graviton mass distribution integral is used.
55958       ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55959         
55960 C...  Ensure minimal open phase space (max(mG*) < m(gamma*))
55961         PCUJET=1D0
55962         
55963 C...  KK photon (?) compressed code and mass
55964         KCGAKK=KCFLA+23
55965         XMGAMK=PMAS(KCGAKK,1)
55966         
55967 C...  Find maximum of (dGamma/dMg)
55968         IF(IN.EQ.0)THEN
55969           RESMAX=0D0
55970           YMAX=0D0
55971           DO 120 I=1,NMAX-1 
55972             Y=I/DBLE(NMAX)
55973             RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55974             IF(RESINT.GE.RESMAX)THEN
55975               RESMAX=RESINT
55976               YMAX=Y
55977             ENDIF
55978  120      CONTINUE
55979         ENDIF
55980         
55981 C...  Pick random graviton mass, accept/reject
55982         AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55983  130    RMG=AMMAX*PYR(0)
55984         X=RMG/XMGAMK
55985         DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55986         IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55987         
55988 C...  If the user has not chosen N=2,4 or 6, STOP
55989       ELSE
55990         WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55991      &       ' (MUST BE 2, 4, OR 6) '
55992         CALL PYSTOP(6002)
55993       ENDIF
55994       
55995 C...  Now store the sampled Mg
55996       PMAS(39,1)=RMG
55997       
55998       RETURN
55999       END
56000       
56001 C*********************************************************************
56002  
56003 C...PYGRAW
56004 C...Universal Extra Dimensions Model (UED)
56005 C...
56006 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
56007 C...
56008 C...Integrand for the KK boson -> SM boson + graviton
56009 C...graviton mass distribution (and gravity mediated total width),
56010 C...which contains (see 0201300 and below for the full product)
56011 C...the gravity mediated partial decay width Gamma(xx, yy)
56012 C... i.e. GRADEN(YY)*PYWDKK(XXA)
56013 C...  where xx is exclusive to gravity
56014 C...  yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56015 C...  and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
56016 
56017       DOUBLE PRECISION FUNCTION PYGRAW(YIN)
56018 
56019 C...Double precision and integer declarations
56020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56021       IMPLICIT INTEGER (I-N)
56022 
56023 C...Pythia commonblocks
56024       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56025 
56026 C...Local UED commonblocks and variables
56027       COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56028       COMMON/INTSAV/YSAV,YMAX,RESMAX
56029 
56030 C...SAVE statements
56031       SAVE /PYDAT1/,/INTSAV/
56032 
56033 C...External: Pythia's Gamma function
56034       EXTERNAL PYGAMM
56035 
56036 C...Pi
56037       PI=PARU(1)
56038       PI2=PI*PI
56039 
56040       YMIN=1.D-9/RINV
56041       YY=YSAV
56042       XX=DSQRT(1.-YY**2)*YIN
56043       DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
56044       FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
56045       XND=(NDIM-1.)/2.
56046       GAMMN=PYGAMM(XND)
56047       FAC=FAC/GAMMN
56048       XXA=DSQRT(XX**2+YY**2)
56049       GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
56050 
56051       PYGRAW=DJAC*
56052      +     FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
56053 
56054       RETURN
56055       END
56056 C*********************************************************************
56057 
56058 C...PYWDKK
56059 C...Universal Extra Dimensions Model (UED)
56060 C...
56061 C...Multiplied by the square modulus of a form factor
56062 C...(see GRADEN in function PYGRAW)
56063 C...PYWDKK is the KK boson -> SM boson + graviton
56064 C...gravity mediated partial decay width Gamma(xx, yy)
56065 C...  where xx is exclusive to gravity
56066 C...  yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56067 C...  and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
56068 C...
56069 C...N.B. The Feynman rules for the couplings of the graviton fields
56070 C...to the UED fields are related to the corresponding couplings of
56071 C...the graviton fields to the SM fields by the form factor.
56072 
56073       DOUBLE PRECISION FUNCTION PYWDKK(X)
56074 
56075 C...Double precision and integer declarations
56076       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56077       IMPLICIT INTEGER (I-N)
56078 
56079 C...Pythia commonblocks
56080       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56081       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56082 
56083 C...Local UED commonblocks and variables
56084       COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56085       COMMON/KAPPA/XKAPPA
56086 
56087 C...SAVE statements
56088       SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
56089 
56090       PI=PARU(1)
56091 
56092 C...gamma* mass 473
56093       KCQKK=473
56094       XMNKK=PMAS(KCQKK,1)
56095 
56096 C...Bosons partial width Macesanu hep-ph/0201300
56097       PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
56098      +          ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
56099 
56100       RETURN
56101       END
56102  
56103 C*********************************************************************
56104  
56105 C...PYEIGC
56106 C...Finds eigenvalues of a general complex matrix
56107 C
56108 C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
56109 C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
56110 C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
56111 C     OF A COMPLEX GENERAL MATRIX.
56112 C
56113 C     ON INPUT
56114 C
56115 C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
56116 C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56117 C        DIMENSION STATEMENT.
56118 C
56119 C        N  IS THE ORDER OF THE MATRIX  A=(AR,AI).
56120 C
56121 C        AR  AND  AI  CONTAIN THE REAL AND IMAGINARY PARTS,
56122 C        RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
56123 C
56124 C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
56125 C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
56126 C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
56127 C
56128 C     ON OUTPUT
56129 C
56130 C        WR  AND  WI  CONTAIN THE REAL AND IMAGINARY PARTS,
56131 C        RESPECTIVELY, OF THE EIGENVALUES.
56132 C
56133 C        ZR  AND  ZI  CONTAIN THE REAL AND IMAGINARY PARTS,
56134 C        RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
56135 C
56136 C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
56137 C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
56138 C           AND COMQR2.  THE NORMAL COMPLETION CODE IS ZERO.
56139 C
56140 C        FV1, FV2, AND  FV3  ARE TEMPORARY STORAGE ARRAYS.
56141 C
56142 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56143 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56144 C
56145 C     THIS VERSION DATED AUGUST 1983.
56146 C
56147  
56148       SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
56149  
56150       INTEGER N,NM,IS1,IS2,IERR,MATZ
56151       DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56152      X       FV1(5),FV2(5),FV3(5)
56153       IF (N .LE. NM) GOTO 100
56154       IERR = 10 * N
56155       GOTO 120
56156 C
56157   100 CALL  PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
56158       CALL  PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
56159       IF (MATZ .NE. 0) GOTO 110
56160 C     .......... FIND EIGENVALUES ONLY ..........
56161       CALL  PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
56162       GOTO 120
56163 C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
56164   110 CALL  PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
56165       IF (IERR .NE. 0) GOTO 120
56166       CALL  PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
56167   120 RETURN
56168       END
56169  
56170 C*********************************************************************
56171  
56172 C...PYCMQR
56173 C...Auxiliary to PYEICG.
56174 C
56175 C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56176 C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
56177 C     AND WILKINSON.
56178 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
56179 C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56180 C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56181 C
56182 C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
56183 C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
56184 C
56185 C     ON INPUT
56186 C
56187 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56188 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56189 C          DIMENSION STATEMENT.
56190 C
56191 C        N IS THE ORDER OF THE MATRIX.
56192 C
56193 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56194 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
56195 C          SET LOW=1, IGH=N.
56196 C
56197 C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56198 C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56199 C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
56200 C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
56201 C          THE REDUCTION BY  CORTH, IF PERFORMED.
56202 C
56203 C     ON OUTPUT
56204 C
56205 C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
56206 C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
56207 C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
56208 C          EIGENVECTORS IS TO BE PERFORMED.
56209 C
56210 C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56211 C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
56212 C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56213 C          FOR INDICES IERR+1,...,N.
56214 C
56215 C        IERR IS SET TO
56216 C          ZERO       FOR NORMAL RETURN,
56217 C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56218 C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56219 C
56220 C     CALLS PYCDIV FOR COMPLEX DIVISION.
56221 C     CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56222 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
56223 C
56224 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56225 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56226 C
56227 C     THIS VERSION DATED AUGUST 1983.
56228 C
56229  
56230       SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
56231  
56232       INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
56233       DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
56234       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56235      X       PYTHAG
56236  
56237       IERR = 0
56238       IF (LOW .EQ. IGH) GOTO 130
56239 C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56240       L = LOW + 1
56241 C
56242       DO 120 I = L, IGH
56243          LL = MIN0(I+1,IGH)
56244          IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
56245          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56246          YR = HR(I,I-1) / NORM
56247          YI = HI(I,I-1) / NORM
56248          HR(I,I-1) = NORM
56249          HI(I,I-1) = 0.0D0
56250 C
56251          DO 100 J = I, IGH
56252             SI = YR * HI(I,J) - YI * HR(I,J)
56253             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56254             HI(I,J) = SI
56255   100    CONTINUE
56256 C
56257          DO 110 J = LOW, LL
56258             SI = YR * HI(J,I) + YI * HR(J,I)
56259             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56260             HI(J,I) = SI
56261   110    CONTINUE
56262 C
56263   120 CONTINUE
56264 C     .......... STORE ROOTS ISOLATED BY CBAL ..........
56265   130 DO 140 I = 1, N
56266          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56267          WR(I) = HR(I,I)
56268          WI(I) = HI(I,I)
56269   140 CONTINUE
56270 C
56271       EN = IGH
56272       TR = 0.0D0
56273       TI = 0.0D0
56274       ITN = 30*N
56275 C     .......... SEARCH FOR NEXT EIGENVALUE ..........
56276   150 IF (EN .LT. LOW) GOTO 320
56277       ITS = 0
56278       ENM1 = EN - 1
56279 C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56280 C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
56281   160 DO 170 LL = LOW, EN
56282          L = EN + LOW - LL
56283          IF (L .EQ. LOW) GOTO 180
56284          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56285      X            + DABS(HR(L,L)) + DABS(HI(L,L))
56286          TST2 = TST1 + DABS(HR(L,L-1))
56287          IF (TST2 .EQ. TST1) GOTO 180
56288   170 CONTINUE
56289 C     .......... FORM SHIFT ..........
56290   180 IF (L .EQ. EN) GOTO 300
56291       IF (ITN .EQ. 0) GOTO 310
56292       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
56293       SR = HR(EN,EN)
56294       SI = HI(EN,EN)
56295       XR = HR(ENM1,EN) * HR(EN,ENM1)
56296       XI = HI(ENM1,EN) * HR(EN,ENM1)
56297       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
56298       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56299       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56300       CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56301       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
56302       ZZR = -ZZR
56303       ZZI = -ZZI
56304   190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56305       SR = SR - XR
56306       SI = SI - XI
56307       GOTO 210
56308 C     .......... FORM EXCEPTIONAL SHIFT ..........
56309   200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56310       SI = 0.0D0
56311 C
56312   210 DO 220 I = LOW, EN
56313          HR(I,I) = HR(I,I) - SR
56314          HI(I,I) = HI(I,I) - SI
56315   220 CONTINUE
56316 C
56317       TR = TR + SR
56318       TI = TI + SI
56319       ITS = ITS + 1
56320       ITN = ITN - 1
56321 C     .......... REDUCE TO TRIANGLE (ROWS) ..........
56322       LP1 = L + 1
56323 C
56324       DO 240 I = LP1, EN
56325          SR = HR(I,I-1)
56326          HR(I,I-1) = 0.0D0
56327          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56328          XR = HR(I-1,I-1) / NORM
56329          WR(I-1) = XR
56330          XI = HI(I-1,I-1) / NORM
56331          WI(I-1) = XI
56332          HR(I-1,I-1) = NORM
56333          HI(I-1,I-1) = 0.0D0
56334          HI(I,I-1) = SR / NORM
56335 C
56336          DO 230 J = I, EN
56337             YR = HR(I-1,J)
56338             YI = HI(I-1,J)
56339             ZZR = HR(I,J)
56340             ZZI = HI(I,J)
56341             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56342             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56343             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56344             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56345   230    CONTINUE
56346 C
56347   240 CONTINUE
56348 C
56349       SI = HI(EN,EN)
56350       IF (SI .EQ. 0.0D0) GOTO 250
56351       NORM = PYTHAG(HR(EN,EN),SI)
56352       SR = HR(EN,EN) / NORM
56353       SI = SI / NORM
56354       HR(EN,EN) = NORM
56355       HI(EN,EN) = 0.0D0
56356 C     .......... INVERSE OPERATION (COLUMNS) ..........
56357   250 DO 280 J = LP1, EN
56358          XR = WR(J-1)
56359          XI = WI(J-1)
56360 C
56361          DO 270 I = L, J
56362             YR = HR(I,J-1)
56363             YI = 0.0D0
56364             ZZR = HR(I,J)
56365             ZZI = HI(I,J)
56366             IF (I .EQ. J) GOTO 260
56367             YI = HI(I,J-1)
56368             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56369   260       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56370             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56371             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56372   270    CONTINUE
56373 C
56374   280 CONTINUE
56375 C
56376       IF (SI .EQ. 0.0D0) GOTO 160
56377 C
56378       DO 290 I = L, EN
56379          YR = HR(I,EN)
56380          YI = HI(I,EN)
56381          HR(I,EN) = SR * YR - SI * YI
56382          HI(I,EN) = SR * YI + SI * YR
56383   290 CONTINUE
56384 C
56385       GOTO 160
56386 C     .......... A ROOT FOUND ..........
56387   300 WR(EN) = HR(EN,EN) + TR
56388       WI(EN) = HI(EN,EN) + TI
56389       EN = ENM1
56390       GOTO 150
56391 C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56392 C                CONVERGED AFTER 30*N ITERATIONS ..........
56393   310 IERR = EN
56394   320 RETURN
56395       END
56396  
56397 C*********************************************************************
56398  
56399 C...PYCMQ2
56400 C...Auxiliary to PYEICG.
56401 C
56402 C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56403 C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
56404 C     AND WILKINSON.
56405 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
56406 C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56407 C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56408 C
56409 C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
56410 C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
56411 C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
56412 C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
56413 C     THIS GENERAL MATRIX TO HESSENBERG FORM.
56414 C
56415 C     ON INPUT
56416 C
56417 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56418 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56419 C          DIMENSION STATEMENT.
56420 C
56421 C        N IS THE ORDER OF THE MATRIX.
56422 C
56423 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56424 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
56425 C          SET LOW=1, IGH=N.
56426 C
56427 C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
56428 C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
56429 C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
56430 C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
56431 C          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
56432 C
56433 C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56434 C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56435 C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
56436 C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
56437 C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
56438 C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
56439 C          ARBITRARY.
56440 C
56441 C     ON OUTPUT
56442 C
56443 C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
56444 C          HAVE BEEN DESTROYED.
56445 C
56446 C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56447 C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
56448 C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56449 C          FOR INDICES IERR+1,...,N.
56450 C
56451 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56452 C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
56453 C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
56454 C          THE EIGENVECTORS HAS BEEN FOUND.
56455 C
56456 C        IERR IS SET TO
56457 C          ZERO       FOR NORMAL RETURN,
56458 C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56459 C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56460 C
56461 C     CALLS PYCDIV FOR COMPLEX DIVISION.
56462 C     CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56463 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
56464 C
56465 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56466 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56467 C
56468 C     THIS VERSION DATED OCTOBER 1989.
56469 C
56470 C  MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
56471 C  MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
56472 C
56473  
56474       SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
56475  
56476       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
56477      X        ITN,ITS,LOW,LP1,ENM1,IEND,IERR
56478       DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56479      X       ORTR(5),ORTI(5)
56480       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56481      X       PYTHAG
56482  
56483       IERR = 0
56484 C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
56485       DO 110 J = 1, N
56486 C
56487          DO 100 I = 1, N
56488             ZR(I,J) = 0.0D0
56489             ZI(I,J) = 0.0D0
56490   100    CONTINUE
56491          ZR(J,J) = 1.0D0
56492   110 CONTINUE
56493 C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
56494 C                FROM THE INFORMATION LEFT BY CORTH ..........
56495       IEND = IGH - LOW - 1
56496       IF (IEND.LT.0) GOTO 220
56497       IF (IEND.EQ.0) GOTO 170
56498 C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
56499       DO 160 II = 1, IEND
56500          I = IGH - II
56501          IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
56502          IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
56503 C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
56504          NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
56505          IP1 = I + 1
56506 C
56507          DO 120 K = IP1, IGH
56508             ORTR(K) = HR(K,I-1)
56509             ORTI(K) = HI(K,I-1)
56510   120    CONTINUE
56511 C
56512          DO 150 J = I, IGH
56513             SR = 0.0D0
56514             SI = 0.0D0
56515 C
56516             DO 130 K = I, IGH
56517                SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
56518                SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
56519   130       CONTINUE
56520 C
56521             SR = SR / NORM
56522             SI = SI / NORM
56523 C
56524             DO 140 K = I, IGH
56525                ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
56526                ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
56527   140       CONTINUE
56528 C
56529   150    CONTINUE
56530 C
56531   160 CONTINUE
56532 C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56533   170 L = LOW + 1
56534 C
56535       DO 210 I = L, IGH
56536          LL = MIN0(I+1,IGH)
56537          IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
56538          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56539          YR = HR(I,I-1) / NORM
56540          YI = HI(I,I-1) / NORM
56541          HR(I,I-1) = NORM
56542          HI(I,I-1) = 0.0D0
56543 C
56544          DO 180 J = I, N
56545             SI = YR * HI(I,J) - YI * HR(I,J)
56546             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56547             HI(I,J) = SI
56548   180    CONTINUE
56549 C
56550          DO 190 J = 1, LL
56551             SI = YR * HI(J,I) + YI * HR(J,I)
56552             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56553             HI(J,I) = SI
56554   190    CONTINUE
56555 C
56556          DO 200 J = LOW, IGH
56557             SI = YR * ZI(J,I) + YI * ZR(J,I)
56558             ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
56559             ZI(J,I) = SI
56560   200    CONTINUE
56561 C
56562   210 CONTINUE
56563 C     .......... STORE ROOTS ISOLATED BY CBAL ..........
56564   220 DO 230 I = 1, N
56565          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
56566          WR(I) = HR(I,I)
56567          WI(I) = HI(I,I)
56568   230 CONTINUE
56569 C
56570       EN = IGH
56571       TR = 0.0D0
56572       TI = 0.0D0
56573       ITN = 30*N
56574 C     .......... SEARCH FOR NEXT EIGENVALUE ..........
56575   240 IF (EN .LT. LOW) GOTO 430
56576       ITS = 0
56577       ENM1 = EN - 1
56578 C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56579 C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
56580   250 DO 260 LL = LOW, EN
56581          L = EN + LOW - LL
56582          IF (L .EQ. LOW) GOTO 270
56583          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56584      X            + DABS(HR(L,L)) + DABS(HI(L,L))
56585          TST2 = TST1 + DABS(HR(L,L-1))
56586          IF (TST2 .EQ. TST1) GOTO 270
56587   260 CONTINUE
56588 C     .......... FORM SHIFT ..........
56589   270 IF (L .EQ. EN) GOTO 420
56590       IF (ITN .EQ. 0) GOTO 550
56591       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
56592       SR = HR(EN,EN)
56593       SI = HI(EN,EN)
56594       XR = HR(ENM1,EN) * HR(EN,ENM1)
56595       XI = HI(ENM1,EN) * HR(EN,ENM1)
56596       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
56597       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56598       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56599       CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56600       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
56601       ZZR = -ZZR
56602       ZZI = -ZZI
56603   280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56604       SR = SR - XR
56605       SI = SI - XI
56606       GOTO 300
56607 C     .......... FORM EXCEPTIONAL SHIFT ..........
56608   290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56609       SI = 0.0D0
56610 C
56611   300 DO 310 I = LOW, EN
56612          HR(I,I) = HR(I,I) - SR
56613          HI(I,I) = HI(I,I) - SI
56614   310 CONTINUE
56615 C
56616       TR = TR + SR
56617       TI = TI + SI
56618       ITS = ITS + 1
56619       ITN = ITN - 1
56620 C     .......... REDUCE TO TRIANGLE (ROWS) ..........
56621       LP1 = L + 1
56622 C
56623       DO 330 I = LP1, EN
56624          SR = HR(I,I-1)
56625          HR(I,I-1) = 0.0D0
56626          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56627          XR = HR(I-1,I-1) / NORM
56628          WR(I-1) = XR
56629          XI = HI(I-1,I-1) / NORM
56630          WI(I-1) = XI
56631          HR(I-1,I-1) = NORM
56632          HI(I-1,I-1) = 0.0D0
56633          HI(I,I-1) = SR / NORM
56634 C
56635          DO 320 J = I, N
56636             YR = HR(I-1,J)
56637             YI = HI(I-1,J)
56638             ZZR = HR(I,J)
56639             ZZI = HI(I,J)
56640             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56641             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56642             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56643             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56644   320    CONTINUE
56645 C
56646   330 CONTINUE
56647 C
56648       SI = HI(EN,EN)
56649       IF (SI .EQ. 0.0D0) GOTO 350
56650       NORM = PYTHAG(HR(EN,EN),SI)
56651       SR = HR(EN,EN) / NORM
56652       SI = SI / NORM
56653       HR(EN,EN) = NORM
56654       HI(EN,EN) = 0.0D0
56655       IF (EN .EQ. N) GOTO 350
56656       IP1 = EN + 1
56657 C
56658       DO 340 J = IP1, N
56659          YR = HR(EN,J)
56660          YI = HI(EN,J)
56661          HR(EN,J) = SR * YR + SI * YI
56662          HI(EN,J) = SR * YI - SI * YR
56663   340 CONTINUE
56664 C     .......... INVERSE OPERATION (COLUMNS) ..........
56665   350 DO 390 J = LP1, EN
56666          XR = WR(J-1)
56667          XI = WI(J-1)
56668 C
56669          DO 370 I = 1, J
56670             YR = HR(I,J-1)
56671             YI = 0.0D0
56672             ZZR = HR(I,J)
56673             ZZI = HI(I,J)
56674             IF (I .EQ. J) GOTO 360
56675             YI = HI(I,J-1)
56676             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56677   360       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56678             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56679             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56680   370    CONTINUE
56681 C
56682          DO 380 I = LOW, IGH
56683             YR = ZR(I,J-1)
56684             YI = ZI(I,J-1)
56685             ZZR = ZR(I,J)
56686             ZZI = ZI(I,J)
56687             ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56688             ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56689             ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56690             ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56691   380    CONTINUE
56692 C
56693   390 CONTINUE
56694 C
56695       IF (SI .EQ. 0.0D0) GOTO 250
56696 C
56697       DO 400 I = 1, EN
56698          YR = HR(I,EN)
56699          YI = HI(I,EN)
56700          HR(I,EN) = SR * YR - SI * YI
56701          HI(I,EN) = SR * YI + SI * YR
56702   400 CONTINUE
56703 C
56704       DO 410 I = LOW, IGH
56705          YR = ZR(I,EN)
56706          YI = ZI(I,EN)
56707          ZR(I,EN) = SR * YR - SI * YI
56708          ZI(I,EN) = SR * YI + SI * YR
56709   410 CONTINUE
56710 C
56711       GOTO 250
56712 C     .......... A ROOT FOUND ..........
56713   420 HR(EN,EN) = HR(EN,EN) + TR
56714       WR(EN) = HR(EN,EN)
56715       HI(EN,EN) = HI(EN,EN) + TI
56716       WI(EN) = HI(EN,EN)
56717       EN = ENM1
56718       GOTO 240
56719 C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
56720 C                VECTORS OF UPPER TRIANGULAR FORM ..........
56721   430 NORM = 0.0D0
56722 C
56723       DO 440 I = 1, N
56724 C
56725          DO 440 J = I, N
56726             TR = DABS(HR(I,J)) + DABS(HI(I,J))
56727             IF (TR .GT. NORM) NORM = TR
56728   440 CONTINUE
56729 C
56730       IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
56731 C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
56732       DO 500 NN = 2, N
56733          EN = N + 2 - NN
56734          XR = WR(EN)
56735          XI = WI(EN)
56736          HR(EN,EN) = 1.0D0
56737          HI(EN,EN) = 0.0D0
56738          ENM1 = EN - 1
56739 C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
56740          DO 490 II = 1, ENM1
56741             I = EN - II
56742             ZZR = 0.0D0
56743             ZZI = 0.0D0
56744             IP1 = I + 1
56745 C
56746             DO 450 J = IP1, EN
56747                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
56748                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
56749   450       CONTINUE
56750 C
56751             YR = XR - WR(I)
56752             YI = XI - WI(I)
56753             IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
56754                TST1 = NORM
56755                YR = TST1
56756   460          YR = 0.01D0 * YR
56757                TST2 = NORM + YR
56758                IF (TST2 .GT. TST1) GOTO 460
56759   470       CONTINUE
56760             CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
56761 C     .......... OVERFLOW CONTROL ..........
56762             TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
56763             IF (TR .EQ. 0.0D0) GOTO 490
56764             TST1 = TR
56765             TST2 = TST1 + 1.0D0/TST1
56766             IF (TST2 .GT. TST1) GOTO 490
56767             DO 480 J = I, EN
56768                HR(J,EN) = HR(J,EN)/TR
56769                HI(J,EN) = HI(J,EN)/TR
56770   480       CONTINUE
56771 C
56772   490    CONTINUE
56773 C
56774   500 CONTINUE
56775 C     .......... END BACKSUBSTITUTION ..........
56776 C     .......... VECTORS OF ISOLATED ROOTS ..........
56777       DO 520 I = 1, N
56778          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
56779 C
56780          DO 510 J = I, N
56781             ZR(I,J) = HR(I,J)
56782             ZI(I,J) = HI(I,J)
56783   510    CONTINUE
56784 C
56785   520 CONTINUE
56786 C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
56787 C                VECTORS OF ORIGINAL FULL MATRIX.
56788 C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
56789       DO 540 JJ = LOW, N
56790          J = N + LOW - JJ
56791          M = MIN0(J,IGH)
56792 C
56793          DO 540 I = LOW, IGH
56794             ZZR = 0.0D0
56795             ZZI = 0.0D0
56796 C
56797             DO 530 K = LOW, M
56798                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
56799                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
56800   530       CONTINUE
56801 C
56802             ZR(I,J) = ZZR
56803             ZI(I,J) = ZZI
56804   540 CONTINUE
56805 C
56806       GOTO 560
56807 C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56808 C                CONVERGED AFTER 30*N ITERATIONS ..........
56809   550 IERR = EN
56810   560 RETURN
56811       END
56812  
56813 C*********************************************************************
56814  
56815 C...PYCDIV
56816 C...Auxiliary to PYCMQR
56817 C
56818 C     COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
56819 C
56820  
56821       SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
56822  
56823       DOUBLE PRECISION AR,AI,BR,BI,CR,CI
56824       DOUBLE PRECISION S,ARS,AIS,BRS,BIS
56825  
56826       S = DABS(BR) + DABS(BI)
56827       ARS = AR/S
56828       AIS = AI/S
56829       BRS = BR/S
56830       BIS = BI/S
56831       S = BRS**2 + BIS**2
56832       CR = (ARS*BRS + AIS*BIS)/S
56833       CI = (AIS*BRS - ARS*BIS)/S
56834       RETURN
56835       END
56836  
56837 C*********************************************************************
56838  
56839 C...PYCSRT
56840 C...Auxiliary to PYCMQR
56841 C
56842 C     (YR,YI) = COMPLEX DSQRT(XR,XI)
56843 C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56844 C
56845  
56846       SUBROUTINE PYCSRT(XR,XI,YR,YI)
56847  
56848       DOUBLE PRECISION XR,XI,YR,YI
56849       DOUBLE PRECISION S,TR,TI,PYTHAG
56850  
56851       TR = XR
56852       TI = XI
56853       S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56854       IF (TR .GE. 0.0D0) YR = S
56855       IF (TI .LT. 0.0D0) S = -S
56856       IF (TR .LE. 0.0D0) YI = S
56857       IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56858       IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56859       RETURN
56860       END
56861  
56862       DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56863       DOUBLE PRECISION A,B
56864 C
56865 C     FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56866 C
56867       DOUBLE PRECISION P,R,S,T,U
56868       P = DMAX1(DABS(A),DABS(B))
56869       IF (P .EQ. 0.0D0) GOTO 110
56870       R = (DMIN1(DABS(A),DABS(B))/P)**2
56871   100 CONTINUE
56872          T = 4.0D0 + R
56873          IF (T .EQ. 4.0D0) GOTO 110
56874          S = R/T
56875          U = 1.0D0 + 2.0D0*S
56876          P = U*P
56877          R = (S/U)**2 * R
56878       GOTO 100
56879   110 PYTHAG = P
56880       RETURN
56881       END
56882  
56883 C*********************************************************************
56884  
56885 C...PYCBAL
56886 C...Auxiliary to PYEICG
56887 C
56888 C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56889 C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56890 C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56891 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56892 C
56893 C     THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56894 C     EIGENVALUES WHENEVER POSSIBLE.
56895 C
56896 C     ON INPUT
56897 C
56898 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56899 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56900 C          DIMENSION STATEMENT.
56901 C
56902 C        N IS THE ORDER OF THE MATRIX.
56903 C
56904 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56905 C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56906 C
56907 C     ON OUTPUT
56908 C
56909 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56910 C          RESPECTIVELY, OF THE BALANCED MATRIX.
56911 C
56912 C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56913 C          ARE EQUAL TO ZERO IF
56914 C           (1) I IS GREATER THAN J AND
56915 C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56916 C
56917 C        SCALE CONTAINS INFORMATION DETERMINING THE
56918 C           PERMUTATIONS AND SCALING FACTORS USED.
56919 C
56920 C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56921 C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56922 C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56923 C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
56924 C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
56925 C                 = D(J,J)       J = LOW,...,IGH
56926 C                 = P(J)         J = IGH+1,...,N.
56927 C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56928 C     THEN 1 TO LOW-1.
56929 C
56930 C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56931 C
56932 C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56933 C     CBAL  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56934 C     K,L HAVE BEEN REVERSED.)
56935 C
56936 C     ARITHMETIC IS REAL THROUGHOUT.
56937 C
56938 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56939 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56940 C
56941 C     THIS VERSION DATED AUGUST 1983.
56942 C
56943  
56944       SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56945  
56946       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56947       DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56948       DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56949       LOGICAL NOCONV
56950  
56951       RADIX = 16.0D0
56952 C
56953       B2 = RADIX * RADIX
56954       K = 1
56955       L = N
56956       GOTO 150
56957 C     .......... IN-LINE PROCEDURE FOR ROW AND
56958 C                COLUMN EXCHANGE ..........
56959   100 SCALE(M) = J
56960       IF (J .EQ. M) GOTO 130
56961 C
56962       DO 110 I = 1, L
56963          F = AR(I,J)
56964          AR(I,J) = AR(I,M)
56965          AR(I,M) = F
56966          F = AI(I,J)
56967          AI(I,J) = AI(I,M)
56968          AI(I,M) = F
56969   110 CONTINUE
56970 C
56971       DO 120 I = K, N
56972          F = AR(J,I)
56973          AR(J,I) = AR(M,I)
56974          AR(M,I) = F
56975          F = AI(J,I)
56976          AI(J,I) = AI(M,I)
56977          AI(M,I) = F
56978   120 CONTINUE
56979 C
56980   130 IF(IEXC.EQ.1) GOTO 140
56981       IF(IEXC.EQ.2) GOTO 180
56982 C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56983 C                AND PUSH THEM DOWN ..........
56984   140 IF (L .EQ. 1) GOTO 320
56985       L = L - 1
56986 C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56987   150 DO 170 JJ = 1, L
56988          J = L + 1 - JJ
56989 C
56990          DO 160 I = 1, L
56991             IF (I .EQ. J) GOTO 160
56992             IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56993   160    CONTINUE
56994 C
56995          M = L
56996          IEXC = 1
56997          GOTO 100
56998   170 CONTINUE
56999 C
57000       GOTO 190
57001 C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
57002 C                AND PUSH THEM LEFT ..........
57003   180 K = K + 1
57004 C
57005   190 DO 210 J = K, L
57006 C
57007          DO 200 I = K, L
57008             IF (I .EQ. J) GOTO 200
57009             IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
57010   200    CONTINUE
57011 C
57012          M = K
57013          IEXC = 2
57014          GOTO 100
57015   210 CONTINUE
57016 C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
57017       DO 220 I = K, L
57018   220 SCALE(I) = 1.0D0
57019 C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
57020   230 NOCONV = .FALSE.
57021 C
57022       DO 310 I = K, L
57023          C = 0.0D0
57024          R = 0.0D0
57025 C
57026          DO 240 J = K, L
57027             IF (J .EQ. I) GOTO 240
57028             C = C + DABS(AR(J,I)) + DABS(AI(J,I))
57029             R = R + DABS(AR(I,J)) + DABS(AI(I,J))
57030   240    CONTINUE
57031 C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
57032          IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
57033          G = R / RADIX
57034          F = 1.0D0
57035          S = C + R
57036   250    IF (C .GE. G) GOTO 260
57037          F = F * RADIX
57038          C = C * B2
57039          GOTO 250
57040   260    G = R * RADIX
57041   270    IF (C .LT. G) GOTO 280
57042          F = F / RADIX
57043          C = C / B2
57044          GOTO 270
57045 C     .......... NOW BALANCE ..........
57046   280    IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
57047          G = 1.0D0 / F
57048          SCALE(I) = SCALE(I) * F
57049          NOCONV = .TRUE.
57050 C
57051          DO 290 J = K, N
57052             AR(I,J) = AR(I,J) * G
57053             AI(I,J) = AI(I,J) * G
57054   290    CONTINUE
57055 C
57056          DO 300 J = 1, L
57057             AR(J,I) = AR(J,I) * F
57058             AI(J,I) = AI(J,I) * F
57059   300    CONTINUE
57060 C
57061   310 CONTINUE
57062 C
57063       IF (NOCONV) GOTO 230
57064 C
57065   320 LOW = K
57066       IGH = L
57067       RETURN
57068       END
57069  
57070 C*********************************************************************
57071  
57072 C...PYCBA2
57073 C...Auxiliary to PYEICG.
57074 C
57075 C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
57076 C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
57077 C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
57078 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
57079 C
57080 C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
57081 C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
57082 C     BALANCED MATRIX DETERMINED BY  CBAL.
57083 C
57084 C     ON INPUT
57085 C
57086 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57087 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57088 C          DIMENSION STATEMENT.
57089 C
57090 C        N IS THE ORDER OF THE MATRIX.
57091 C
57092 C        LOW AND IGH ARE INTEGERS DETERMINED BY  CBAL.
57093 C
57094 C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
57095 C          AND SCALING FACTORS USED BY  CBAL.
57096 C
57097 C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
57098 C
57099 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57100 C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
57101 C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
57102 C
57103 C     ON OUTPUT
57104 C
57105 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57106 C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
57107 C          IN THEIR FIRST M COLUMNS.
57108 C
57109 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57110 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57111 C
57112 C     THIS VERSION DATED AUGUST 1983.
57113 C
57114  
57115       SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
57116  
57117       INTEGER I,J,K,M,N,II,NM,IGH,LOW
57118       DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
57119       DOUBLE PRECISION S
57120  
57121       IF (M .EQ. 0) GOTO 150
57122       IF (IGH .EQ. LOW) GOTO 120
57123 C
57124       DO 110 I = LOW, IGH
57125          S = SCALE(I)
57126 C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
57127 C                IF THE FOREGOING STATEMENT IS REPLACED BY
57128 C                S=1.0D0/SCALE(I). ..........
57129          DO 100 J = 1, M
57130             ZR(I,J) = ZR(I,J) * S
57131             ZI(I,J) = ZI(I,J) * S
57132   100    CONTINUE
57133 C
57134   110 CONTINUE
57135 C     .......... FOR I=LOW-1 STEP -1 UNTIL 1,
57136 C                IGH+1 STEP 1 UNTIL N DO -- ..........
57137   120 DO 140 II = 1, N
57138          I = II
57139          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
57140          IF (I .LT. LOW) I = LOW - II
57141          K = SCALE(I)
57142          IF (K .EQ. I) GOTO 140
57143 C
57144          DO 130 J = 1, M
57145             S = ZR(I,J)
57146             ZR(I,J) = ZR(K,J)
57147             ZR(K,J) = S
57148             S = ZI(I,J)
57149             ZI(I,J) = ZI(K,J)
57150             ZI(K,J) = S
57151   130    CONTINUE
57152 C
57153   140 CONTINUE
57154 C
57155   150 RETURN
57156       END
57157  
57158 C*********************************************************************
57159  
57160 C...PYCRTH
57161 C...Auxiliary to PYEICG.
57162 C
57163 C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
57164 C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
57165 C     BY MARTIN AND WILKINSON.
57166 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
57167 C
57168 C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
57169 C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
57170 C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
57171 C     UNITARY SIMILARITY TRANSFORMATIONS.
57172 C
57173 C     ON INPUT
57174 C
57175 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57176 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57177 C          DIMENSION STATEMENT.
57178 C
57179 C        N IS THE ORDER OF THE MATRIX.
57180 C
57181 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
57182 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
57183 C          SET LOW=1, IGH=N.
57184 C
57185 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57186 C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
57187 C
57188 C     ON OUTPUT
57189 C
57190 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57191 C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
57192 C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
57193 C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
57194 C          HESSENBERG MATRIX.
57195 C
57196 C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
57197 C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
57198 C
57199 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
57200 C
57201 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57202 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57203 C
57204 C     THIS VERSION DATED AUGUST 1983.
57205 C
57206  
57207       SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
57208  
57209       INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
57210       DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
57211       DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
57212  
57213       LA = IGH - 1
57214       KP1 = LOW + 1
57215       IF (LA .LT. KP1) GOTO 210
57216 C
57217       DO 200 M = KP1, LA
57218          H = 0.0D0
57219          ORTR(M) = 0.0D0
57220          ORTI(M) = 0.0D0
57221          SCALE = 0.0D0
57222 C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
57223          DO 100 I = M, IGH
57224   100    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
57225 C
57226          IF (SCALE .EQ. 0.0D0) GOTO 200
57227          MP = M + IGH
57228 C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57229          DO 110 II = M, IGH
57230             I = MP - II
57231             ORTR(I) = AR(I,M-1) / SCALE
57232             ORTI(I) = AI(I,M-1) / SCALE
57233             H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
57234   110    CONTINUE
57235 C
57236          G = DSQRT(H)
57237          F = PYTHAG(ORTR(M),ORTI(M))
57238          IF (F .EQ. 0.0D0) GOTO 120
57239          H = H + F * G
57240          G = G / F
57241          ORTR(M) = (1.0D0 + G) * ORTR(M)
57242          ORTI(M) = (1.0D0 + G) * ORTI(M)
57243          GOTO 130
57244 C
57245   120    ORTR(M) = G
57246          AR(M,M-1) = SCALE
57247 C     .......... FORM (I-(U*UT)/H) * A ..........
57248   130    DO 160 J = M, N
57249             FR = 0.0D0
57250             FI = 0.0D0
57251 C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57252             DO 140 II = M, IGH
57253                I = MP - II
57254                FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
57255                FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
57256   140       CONTINUE
57257 C
57258             FR = FR / H
57259             FI = FI / H
57260 C
57261             DO 150 I = M, IGH
57262                AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
57263                AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
57264   150       CONTINUE
57265 C
57266   160    CONTINUE
57267 C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
57268          DO 190 I = 1, IGH
57269             FR = 0.0D0
57270             FI = 0.0D0
57271 C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
57272             DO 170 JJ = M, IGH
57273                J = MP - JJ
57274                FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
57275                FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
57276   170       CONTINUE
57277 C
57278             FR = FR / H
57279             FI = FI / H
57280 C
57281             DO 180 J = M, IGH
57282                AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
57283                AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
57284   180       CONTINUE
57285 C
57286   190    CONTINUE
57287 C
57288          ORTR(M) = SCALE * ORTR(M)
57289          ORTI(M) = SCALE * ORTI(M)
57290          AR(M,M-1) = -G * AR(M,M-1)
57291          AI(M,M-1) = -G * AI(M,M-1)
57292   200 CONTINUE
57293 C
57294   210 RETURN
57295       END
57296  
57297 C*********************************************************************
57298  
57299 C...PYLDCM
57300 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57301 C...processes.
57302  
57303       SUBROUTINE PYLDCM(A,N,NP,INDX,D)
57304       IMPLICIT NONE
57305       INTEGER N,NP,INDX(N)
57306       REAL*8 D,TINY
57307       COMPLEX*16 A(NP,NP)
57308       PARAMETER (TINY=1.0D-20)
57309       INTEGER I,IMAX,J,K
57310       REAL*8 AAMAX,VV(6),DUM
57311       COMPLEX*16 SUM,DUMC
57312  
57313       D=1D0
57314       DO 110 I=1,N
57315         AAMAX=0D0
57316         DO 100 J=1,N
57317           IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
57318   100   CONTINUE
57319         IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
57320         VV(I)=1D0/AAMAX
57321   110 CONTINUE
57322       DO 180 J=1,N
57323         DO 130 I=1,J-1
57324           SUM=A(I,J)
57325           DO 120 K=1,I-1
57326             SUM=SUM-A(I,K)*A(K,J)
57327   120     CONTINUE
57328           A(I,J)=SUM
57329   130   CONTINUE
57330         AAMAX=0D0
57331         DO 150 I=J,N
57332           SUM=A(I,J)
57333           DO 140 K=1,J-1
57334             SUM=SUM-A(I,K)*A(K,J)
57335   140     CONTINUE
57336           A(I,J)=SUM
57337           DUM=VV(I)*ABS(SUM)
57338           IF (DUM.GE.AAMAX) THEN
57339             IMAX=I
57340             AAMAX=DUM
57341           ENDIF
57342   150   CONTINUE
57343         IF (J.NE.IMAX)THEN
57344           DO 160 K=1,N
57345             DUMC=A(IMAX,K)
57346             A(IMAX,K)=A(J,K)
57347             A(J,K)=DUMC
57348   160     CONTINUE
57349           D=-D
57350           VV(IMAX)=VV(J)
57351         ENDIF
57352         INDX(J)=IMAX
57353         IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
57354         IF(J.NE.N)THEN
57355           DO 170 I=J+1,N
57356             A(I,J)=A(I,J)/A(J,J)
57357   170     CONTINUE
57358         ENDIF
57359   180 CONTINUE
57360  
57361       RETURN
57362       END
57363  
57364 C*********************************************************************
57365  
57366 C...PYBKSB
57367 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57368 C...processes.
57369  
57370       SUBROUTINE PYBKSB(A,N,NP,INDX,B)
57371       IMPLICIT NONE
57372       INTEGER N,NP,INDX(N)
57373       COMPLEX*16 A(NP,NP),B(N)
57374       INTEGER I,II,J,LL
57375       COMPLEX*16 SUM
57376  
57377       II=0
57378       DO 110 I=1,N
57379         LL=INDX(I)
57380         SUM=B(LL)
57381         B(LL)=B(I)
57382         IF (II.NE.0)THEN
57383           DO 100 J=II,I-1
57384             SUM=SUM-A(I,J)*B(J)
57385   100     CONTINUE
57386         ELSE IF (ABS(SUM).NE.0D0) THEN
57387           II=I
57388         ENDIF
57389         B(I)=SUM
57390   110 CONTINUE
57391       DO 130 I=N,1,-1
57392         SUM=B(I)
57393         DO 120 J=I+1,N
57394           SUM=SUM-A(I,J)*B(J)
57395   120   CONTINUE
57396         B(I)=SUM/A(I,I)
57397   130 CONTINUE
57398       RETURN
57399       END
57400  
57401 C***********************************************************************
57402  
57403 C...PYWIDX
57404 C...Calculates full and partial widths of resonances.
57405 C....copy of PYWIDT, used for techniparticle widths
57406  
57407       SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
57408  
57409 C...Double precision and integer declarations.
57410       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57411       IMPLICIT INTEGER(I-N)
57412       INTEGER PYK,PYCHGE,PYCOMP
57413 C...Parameter statement to help give large particle numbers.
57414       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57415      &KEXCIT=4000000,KDIMEN=5000000)
57416 C...Commonblocks.
57417       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57418       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57419       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57420       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57421       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57422       COMMON/PYINT1/MINT(400),VINT(400)
57423       COMMON/PYINT4/MWID(500),WIDS(500,5)
57424       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57425       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57426       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
57427      &/PYINT4/,/PYMSSM/,/PYTCSM/
57428 C...Local arrays and saved variables.
57429       DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
57430      &WID2SV(3,2)
57431       SAVE MOFSV,WIDWSV,WID2SV
57432       DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
57433  
57434 C...Compressed code and sign; mass.
57435       KFLA=IABS(KFLR)
57436       KFLS=ISIGN(1,KFLR)
57437       KC=PYCOMP(KFLA)
57438       SHR=SQRT(SH)
57439       PMR=PMAS(KC,1)
57440  
57441 C...Reset width information.
57442       DO I=0,400
57443         WDTP(I)=0D0
57444       ENDDO
57445  
57446 C...Common electroweak and strong constants.
57447       XW=PARU(102)
57448       XWV=XW
57449       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
57450       XW1=1D0-XW
57451       AEM=PYALEM(SH)
57452       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
57453       AS=PYALPS(SH)
57454       RADC=1D0+AS/PARU(1)
57455  
57456       IF(KFLA.EQ.23) THEN
57457 C...Z0:
57458         XWC=1D0/(16D0*XW*XW1)
57459         FAC=(AEM*XWC/3D0)*SHR
57460   120   CONTINUE
57461         DO 130 I=1,MDCY(KC,3)
57462           IDC=I+MDCY(KC,2)-1
57463           IF(MDME(IDC,1).LT.0) GOTO 130
57464           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57465           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57466           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
57467           IF(I.LE.8) THEN
57468 C...Z0 -> q + qbar
57469             EF=KCHG(I,1)/3D0
57470             AF=SIGN(1D0,EF+0.1D0)
57471             VF=AF-4D0*EF*XWV
57472             FCOF=3D0*RADC
57473             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
57474           ELSEIF(I.LE.16) THEN
57475 C...Z0 -> l+ + l-, nu + nubar
57476             EF=KCHG(I+2,1)/3D0
57477             AF=SIGN(1D0,EF+0.1D0)
57478             VF=AF-4D0*EF*XWV
57479             FCOF=1D0
57480           ENDIF
57481           BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
57482           WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
57483      &    BE34
57484           WDTP(0)=WDTP(0)+WDTP(I)
57485   130   CONTINUE
57486  
57487  
57488       ELSEIF(KFLA.EQ.24) THEN
57489 C...W+/-:
57490         FAC=(AEM/(24D0*XW))*SHR
57491         DO 140 I=1,MDCY(KC,3)
57492           IDC=I+MDCY(KC,2)-1
57493           IF(MDME(IDC,1).LT.0) GOTO 140
57494           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57495           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57496           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
57497           WID2=1D0
57498           IF(I.LE.16) THEN
57499 C...W+/- -> q + qbar'
57500             FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
57501           ELSEIF(I.LE.20) THEN
57502 C...W+/- -> l+/- + nu
57503             FCOF=1D0
57504           ENDIF
57505           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
57506      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
57507           WDTP(0)=WDTP(0)+WDTP(I)
57508   140   CONTINUE
57509  
57510 C.....V8 -> quark anti-quark
57511       ELSEIF(KFLA.EQ.KTECHN+100021) THEN
57512         FAC=AS/6D0*SHR
57513         TANT3=RTCM(21)
57514         IF(ITCM(2).EQ.0) THEN
57515           IMDL=1
57516         ELSEIF(ITCM(2).EQ.1) THEN
57517           IMDL=2
57518         ENDIF
57519         DO 150 I=1,MDCY(KC,3)
57520           IDC=I+MDCY(KC,2)-1
57521           IF(MDME(IDC,1).LT.0) GOTO 150
57522           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
57523           RM1=PM1**2/SH
57524           IF(RM1.GT.0.25D0) GOTO 150
57525           WID2=1D0
57526           IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
57527             FMIX=1D0/TANT3**2
57528           ELSE
57529             FMIX=TANT3**2
57530           ENDIF
57531           WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
57532           IF(I.EQ.6) WID2=WIDS(6,1)
57533           WDTP(0)=WDTP(0)+WDTP(I)
57534   150   CONTINUE
57535       ENDIF
57536  
57537       RETURN
57538       END
57539  
57540 C*********************************************************************
57541  
57542 C...PYRVSF
57543 C...Calculates R-violating decays of sfermions.
57544 C...P. Z. Skands
57545  
57546       SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
57547  
57548 C...Double precision and integer declarations.
57549       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57550       IMPLICIT INTEGER(I-N)
57551 C...Parameter statement to help give large particle numbers.
57552       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57553      &KEXCIT=4000000,KDIMEN=5000000)
57554 C...Commonblocks.
57555       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57556       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57557       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57558      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57559       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57560 C...Local variables.
57561       DOUBLE PRECISION XLAM(0:400)
57562       INTEGER IDLAM(400,3), PYCOMP
57563       SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
57564  
57565 C...IS R-VIOLATION ON ?
57566       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57567 C...Mass eigenstate counter
57568         ICNT=INT(KFIN/KSUSY1)
57569 C...SM KF code of SUSY particle
57570         KFSM=KFIN-ICNT*KSUSY1
57571 C...Squared Sparticle Mass
57572         SM=PMAS(PYCOMP(KFIN),1)**2
57573 C... Squared mass of top quark
57574         SMT=PMAS(PYCOMP(6),1)**2
57575 C...IS L-VIOLATION ON ?
57576         IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
57577 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
57578           IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
57579      &         THEN
57580             K=INT((KFSM-9)/2)
57581             DO 110 I=1,3
57582               DO 100 J=1,3
57583                 IF(I.NE.J) THEN
57584 C...~e,~mu,~tau -> nu_I + lepton-_J
57585                   LKNT = LKNT+1
57586                   IDLAM(LKNT,1)= 12 +2*(I-1)
57587                   IDLAM(LKNT,2)= 11 +2*(J-1)
57588                   IDLAM(LKNT,3)= 0
57589                   XLAM(LKNT)=0D0
57590                   RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57591                   IF (IMSS(51).NE.0) XLAM(LKNT) =
57592      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57593 C...KINEMATICS CHECK
57594                   IF (XLAM(LKNT).EQ.0D0) THEN
57595                     LKNT=LKNT-1
57596                   ENDIF
57597                 ENDIF
57598   100         CONTINUE
57599   110       CONTINUE
57600 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
57601             J=INT((KFSM-9)/2)
57602             DO 130 I=1,3
57603               IF(I.NE.J) THEN
57604                 DO 120 K=1,3
57605                   LKNT = LKNT+1
57606                   IDLAM(LKNT,1)=-12 -2*(I-1)
57607                   IDLAM(LKNT,2)= 11 +2*(K-1)
57608                   IDLAM(LKNT,3)= 0
57609                   XLAM(LKNT)=0D0
57610                   RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57611                   IF (IMSS(51).NE.0) XLAM(LKNT) =
57612      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57613 C...KINEMATICS CHECK
57614                   IF (XLAM(LKNT).EQ.0D0) THEN
57615                     LKNT=LKNT-1
57616                   ENDIF
57617   120           CONTINUE
57618               ENDIF
57619   130       CONTINUE
57620 C...~e,~mu,~tau -> u_Jbar + d_K
57621             I=INT((KFSM-9)/2)
57622             DO 150 J=1,3
57623               DO 140 K=1,3
57624                 LKNT = LKNT+1
57625                 IDLAM(LKNT,1)=-2 -2*(J-1)
57626                 IDLAM(LKNT,2)= 1 +2*(K-1)
57627                 IDLAM(LKNT,3)= 0
57628                 XLAM(LKNT)=0
57629                 IF (IMSS(52).NE.0) THEN
57630 C...Use massive top quark
57631                   IF (IDLAM(LKNT,1).EQ.-6) THEN
57632                     RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
57633      &                   * (SM-SMT)
57634                     XLAM(LKNT) =
57635      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57636 C...If no top quark, all decay products massless
57637                   ELSE
57638                     RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57639                     XLAM(LKNT) =
57640      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57641                   ENDIF
57642 C...KINEMATICS CHECK
57643                   IF (XLAM(LKNT).EQ.0D0) THEN
57644                     LKNT=LKNT-1
57645                   ENDIF
57646                 ENDIF
57647   140         CONTINUE
57648   150       CONTINUE
57649           ENDIF
57650 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
57651 C...No right-handed neutrinos
57652           IF(ICNT.EQ.1) THEN
57653             IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
57654               J=INT((KFSM-10)/2)
57655               DO 170 I=1,3
57656                 DO 160 K=1,3
57657                   IF (I.NE.J) THEN
57658 C...~nu_J -> lepton+_I + lepton-_K
57659                     LKNT = LKNT+1
57660                     IDLAM(LKNT,1)=-11 -2*(I-1)
57661                     IDLAM(LKNT,2)= 11 +2*(K-1)
57662                     IDLAM(LKNT,3)=  0
57663                     XLAM(LKNT)=0D0
57664                     RM2=RVLAM(I,J,K)**2 * SM
57665                     IF (IMSS(51).NE.0) XLAM(LKNT) =
57666      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57667 C...KINEMATICS CHECK
57668                     IF (XLAM(LKNT).EQ.0D0) THEN
57669                       LKNT=LKNT-1
57670                     ENDIF
57671                   ENDIF
57672   160           CONTINUE
57673   170         CONTINUE
57674 C...~nu_I -> dbar_J + d_K
57675               I=INT((KFSM-10)/2)
57676               DO 190 J=1,3
57677                 DO 180 K=1,3
57678                   LKNT = LKNT+1
57679                   IDLAM(LKNT,1)=-1 -2*(J-1)
57680                   IDLAM(LKNT,2)= 1 +2*(K-1)
57681                   IDLAM(LKNT,3)= 0
57682                   XLAM(LKNT)=0D0
57683                   RM2=3*RVLAMP(I,J,K)**2 * SM
57684                   IF (IMSS(52).NE.0) XLAM(LKNT) =
57685      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57686 C...KINEMATICS CHECK
57687                   IF (XLAM(LKNT).EQ.0D0) THEN
57688                     LKNT=LKNT-1
57689                   ENDIF
57690   180           CONTINUE
57691   190         CONTINUE
57692             ENDIF
57693           ENDIF
57694 C * SDOWN -> NU(BAR) + D and LEPTON- + U
57695           IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57696             J=INT((KFSM+1)/2)
57697             DO 210 I=1,3
57698               DO 200 K=1,3
57699 C...~d_J -> nu_Ibar + d_K
57700                 LKNT = LKNT+1
57701                 IDLAM(LKNT,1)=-12 -2*(I-1)
57702                 IDLAM(LKNT,2)=  1 +2*(K-1)
57703                 IDLAM(LKNT,3)=  0
57704                 XLAM(LKNT)=0D0
57705                 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57706                 IF (IMSS(52).NE.0) XLAM(LKNT) =
57707      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57708 C...KINEMATICS CHECK
57709                 IF (XLAM(LKNT).EQ.0D0) THEN
57710                   LKNT=LKNT-1
57711                 ENDIF
57712   200         CONTINUE
57713   210       CONTINUE
57714             K=INT((KFSM+1)/2)
57715             DO 240 I=1,3
57716               DO 230 J=1,3
57717 C...~d_K -> nu_I + d_J
57718                 LKNT = LKNT+1
57719                 IDLAM(LKNT,1)= 12 +2*(I-1)
57720                 IDLAM(LKNT,2)=  1 +2*(J-1)
57721                 IDLAM(LKNT,3)=  0
57722                 XLAM(LKNT)=0D0
57723                 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57724                 IF (IMSS(52).NE.0) XLAM(LKNT) =
57725      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57726 C...KINEMATICS CHECK
57727                 IF (XLAM(LKNT).EQ.0D0) THEN
57728                   LKNT=LKNT-1
57729                 ENDIF
57730 C...~d_K -> lepton_I- + u_J
57731   220           LKNT = LKNT+1
57732                 IDLAM(LKNT,1)= 11 +2*(I-1)
57733                 IDLAM(LKNT,2)=  2 +2*(J-1)
57734                 IDLAM(LKNT,3)=  0
57735                 XLAM(LKNT)=0D0
57736                 IF (IMSS(52).NE.0) THEN
57737 C...Use massive top quark
57738                   IF (IDLAM(LKNT,2).EQ.6) THEN
57739                     RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
57740                     XLAM(LKNT) =
57741      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
57742 C...If no top quark, all decay products massless
57743                   ELSE
57744                     RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57745                     XLAM(LKNT) =
57746      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57747                   ENDIF
57748 C...KINEMATICS CHECK
57749                   IF (XLAM(LKNT).EQ.0D0) THEN
57750                     LKNT=LKNT-1
57751                   ENDIF
57752                 ENDIF
57753   230         CONTINUE
57754   240       CONTINUE
57755           ENDIF
57756 C * SUP -> LEPTON+ + D
57757           IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57758             J=NINT(KFSM/2.)
57759             DO 260 I=1,3
57760               DO 250 K=1,3
57761 C...~u_J -> lepton_I+ + d_K
57762                 LKNT = LKNT+1
57763                 IDLAM(LKNT,1)=-11 -2*(I-1)
57764                 IDLAM(LKNT,2)=  1 +2*(K-1)
57765                 IDLAM(LKNT,3)=  0
57766                 XLAM(LKNT)=0D0
57767                 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57768                 IF (IMSS(52).NE.0) XLAM(LKNT) =
57769      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57770 C...KINEMATICS CHECK
57771                 IF (XLAM(LKNT).EQ.0D0) THEN
57772                   LKNT=LKNT-1
57773                 ENDIF
57774   250         CONTINUE
57775   260       CONTINUE
57776           ENDIF
57777         ENDIF
57778 C...BARYON NUMBER VIOLATING DECAYS
57779         IF (IMSS(53).GE.1) THEN
57780 C * SUP -> DBAR + DBAR
57781           IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57782             I = KFSM/2
57783             DO 280 J=1,3
57784               DO 270 K=1,3
57785 C...~u_I -> dbar_J + dbar_K
57786                 IF (J.LT.K) THEN
57787 C...(anti-) symmetry J <-> K.
57788                   LKNT = LKNT + 1
57789                   IDLAM(LKNT,1) = -1 -2*(J-1)
57790                   IDLAM(LKNT,2) = -1 -2*(K-1)
57791                   IDLAM(LKNT,3) =  0
57792                   XLAM(LKNT)    =  0D0
57793                   RM2 = 2.*(RVLAMB(I,J,K)**2)
57794      &                 * SFMIX(KFSM,2*ICNT)**2 * SM
57795                   XLAM(LKNT)    =
57796      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57797 C...KINEMATICS CHECK
57798                   IF (XLAM(LKNT).EQ.0D0) THEN
57799                     LKNT = LKNT-1
57800                   ENDIF
57801                 ENDIF
57802   270         CONTINUE
57803   280       CONTINUE
57804           ENDIF
57805 C * SDOWN -> UBAR + DBAR
57806           IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57807             K=(KFSM+1)/2
57808             DO 300 I=1,3
57809               DO 290 J=1,3
57810 C...LAMB coupling antisymmetric in J and K.
57811                 IF (J.NE.K) THEN
57812 C...~d_K -> ubar_I + dbar_K
57813                   LKNT = LKNT + 1
57814                   IDLAM(LKNT,1)= -2 -2*(I-1)
57815                   IDLAM(LKNT,2)= -1 -2*(J-1)
57816                   IDLAM(LKNT,3)=  0
57817                   XLAM(LKNT)=0D0
57818 C...Use massive top quark
57819                   IF (IDLAM(LKNT,1).EQ.-6) THEN
57820                     RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
57821      &                   )
57822                     XLAM(LKNT) =
57823      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57824 C...If no top quark, all decay products massless
57825                   ELSE
57826                     RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57827                     XLAM(LKNT) =
57828      &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57829                   ENDIF
57830 C...KINEMATICS CHECK
57831                   IF (XLAM(LKNT).EQ.0D0) THEN
57832                     LKNT=LKNT-1
57833                   ENDIF
57834                 ENDIF
57835   290         CONTINUE
57836   300       CONTINUE
57837           ENDIF
57838         ENDIF
57839       ENDIF
57840  
57841       RETURN
57842       END
57843  
57844 C*********************************************************************
57845  
57846 C...PYRVNE
57847 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57848 C...P. Z. Skands
57849  
57850       SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57851  
57852 C...Double precision and integer declarations.
57853       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57854       IMPLICIT INTEGER(I-N)
57855 C...Parameter statement to help give large particle numbers.
57856       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57857      &KEXCIT=4000000,KDIMEN=5000000)
57858 C...Commonblocks.
57859       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57860       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57861       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57862       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57863      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57864       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57865 C...Local variables.
57866       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57867      &     ,DCMASS,KFR(3)
57868       DOUBLE PRECISION XLAM(0:400)
57869       DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57870       INTEGER IDLAM(400,3), PYCOMP
57871       LOGICAL DCMASS
57872       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57873  
57874 C...R-VIOLATING DECAYS
57875       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57876         KFSM=KFIN-KSUSY1
57877         IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57878 C...WHICH NEUTRALINO ?
57879           NCHI=1
57880           IF (KFSM.EQ.23) NCHI=2
57881           IF (KFSM.EQ.25) NCHI=3
57882           IF (KFSM.EQ.35) NCHI=4
57883 C...SIGN OF MASS (Opposite convention as HERWIG)
57884           ISM = 1
57885           IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57886  
57887 C...Useful parameters for the calculation of the A and B constants.
57888           WMASS = PMAS(PYCOMP(24),1)
57889           ECHG = 2*SQRT(PARU(103)*PARU(1))
57890           COSB=1/(SQRT(1+RMSS(5)**2))
57891           SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57892           COSW=SQRT(1-PARU(102))
57893           SINW=SQRT(PARU(102))
57894           GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57895 C...Run quark masses to neutralino mass squared (for Higgs-type
57896 C...couplings)
57897           SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57898           DO 100 I=1,6
57899             RMQ(I)=PYMRUN(I,SQMCHI)
57900   100     CONTINUE
57901 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57902             DO 110 NCHJ=1,4
57903               ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57904               ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57905               ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57906               ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57907   110       CONTINUE
57908             C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57909             C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57910             C2=ECHG*ZPMIX(NCHI,1)
57911             C3=GW*ZPMIX(NCHI,2)/COSW
57912             EU=2D0/3D0
57913             ED=-1D0/3D0
57914 C... AB(x,y,z):
57915 C       x=1-2  : Select A or B constant     (1:A ; 2:B)
57916 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57917 C                                    11-16:e,nu_e,mu,...)
57918 C       z=1-2  : Mass eigenstate number
57919 C...CALCULATE COUPLINGS
57920           DO 120 I = 11,15,2
57921             CMS=PMAS(PYCOMP(I),1)
57922 C...Intermediate sleptons
57923             AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57924      &           *(C2-C3*SINW**2))
57925             AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57926      &           *(C2-C3*SINW**2))
57927             AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57928      &           **2))
57929             AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57930      &           **2))
57931 C...Inermediate sneutrinos
57932             AB(1,I+1,1)=0D0
57933             AB(2,I+1,1)=5D-1*C3
57934             AB(1,I+1,2)=0D0
57935             AB(2,I+1,2)=0D0
57936 C...Inermediate sdown
57937             J=I-10
57938             CMS=RMQ(J)
57939             AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57940      &           *ED*(C2-C3*SINW**2))
57941             AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57942      &           *ED*(C2-C3*SINW**2))
57943             AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57944      &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57945             AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57946      &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57947 C...Inermediate sup
57948             J=J+1
57949             CMS=RMQ(J)
57950             AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57951      &           *EU*(C2-C3*SINW**2))
57952             AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57953      &           *EU*(C2-C3*SINW**2))
57954             AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57955      &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57956             AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57957      &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57958   120     CONTINUE
57959  
57960           IF (IMSS(51).GE.1) THEN
57961 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57962 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57963 C...STEP IN I,J,K USING SINGLE COUNTER
57964             DO 130 ISC=0,26
57965 C...LAMBDA COUPLING ASYM IN I,J
57966               IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57967                 LKNT = LKNT+1
57968                 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57969                 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57970                 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57971                 XLAM(LKNT)    = 0D0
57972 C...Set coupling, and decay product masses on/off
57973                 RVLAMC        = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57974      &               ,MOD(ISC,3)+1)**2
57975                 DCMASS=.FALSE.
57976                 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57977      &               DCMASS = .TRUE.
57978 C...Resonance KF codes (1=I,2=J,3=K)
57979                 KFR(1)=-IDLAM(LKNT,1)
57980                 KFR(2)=-IDLAM(LKNT,2)
57981                 KFR(3)=-IDLAM(LKNT,3)
57982 C...Calculate width.
57983                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57984      &               IDLAM(LKNT,3),XLAM(LKNT))
57985                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57986 C...Charge conjugate mode.
57987                 LKNT=LKNT+1
57988                 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57989                 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57990                 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57991                 XLAM(LKNT)=XLAM(LKNT-1)
57992 C...KINEMATICS CHECK
57993                 IF (XLAM(LKNT).EQ.0D0) THEN
57994                   LKNT=LKNT-2
57995                 ENDIF
57996               ENDIF
57997   130       CONTINUE
57998           ENDIF
57999  
58000           IF (IMSS(52).GE.1) THEN
58001 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
58002 C * CHI0 -> NUBAR_I + DBAR_J + D_K
58003             DO 140 ISC=0,26
58004               LKNT = LKNT+1
58005               IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58006               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58007               IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58008               XLAM(LKNT)    =  0D0
58009 C...Set coupling, and decay product masses on/off
58010               RVLAMC        = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
58011      &             ,MOD(ISC,3)+1)**2
58012               DCMASS=.FALSE.
58013               IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
58014      &             DCMASS = .TRUE.
58015 C...Resonance KF codes (1=I,2=J,3=K)
58016               KFR(1)=-IDLAM(LKNT,1)
58017               KFR(2)=-IDLAM(LKNT,2)
58018               KFR(3)=-IDLAM(LKNT,3)
58019 C...Calculate width.
58020               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58021      &             ,XLAM(LKNT))
58022               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58023 C...Charge conjugate mode.
58024               LKNT=LKNT+1
58025               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58026               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58027               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58028               XLAM(LKNT)=XLAM(LKNT-1)
58029 C...KINEMATICS CHECK
58030               IF (XLAM(LKNT).EQ.0D0) THEN
58031                 LKNT=LKNT-2
58032               ENDIF
58033  
58034 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
58035               LKNT = LKNT+1
58036               IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58037               IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58038               IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58039               XLAM(LKNT)    =  0D0
58040 C...Set coupling, and decay product masses on/off
58041               RVLAMC        = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
58042      &             ,MOD(ISC,3)+1)**2
58043               DCMASS=.FALSE.
58044               IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58045      &             .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58046 C...Resonance KF codes (1=I,2=J,3=K)
58047               KFR(1)=-IDLAM(LKNT,1)
58048               KFR(2)=-IDLAM(LKNT,2)
58049               KFR(3)=-IDLAM(LKNT,3)
58050 C...Calculate width.
58051               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58052      &             ,XLAM(LKNT))
58053               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58054 C...Charge conjugate mode.
58055               LKNT=LKNT+1
58056               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58057               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58058               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58059               XLAM(LKNT)=XLAM(LKNT-1)
58060 C...KINEMATICS CHECK
58061               IF (XLAM(LKNT).EQ.0D0) THEN
58062                 LKNT=LKNT-2
58063               ENDIF
58064   140       CONTINUE
58065           ENDIF
58066  
58067           IF (IMSS(53).GE.1) THEN
58068 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
58069 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
58070             DO 150 ISC=0,26
58071 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
58072               IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58073                 LKNT = LKNT+1
58074                 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58075                 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58076                 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58077                 XLAM(LKNT)    =  0D0
58078 C...Set coupling, and decay product masses on/off
58079                 RVLAMC        = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
58080      &               +1,MOD(ISC,3)+1)**2
58081                 DCMASS=.FALSE.
58082                 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58083      &               .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58084 C...Resonance KF codes (1=I,2=J,3=K)
58085                 KFR(1) = IDLAM(LKNT,1)
58086                 KFR(2) = IDLAM(LKNT,2)
58087                 KFR(3) = IDLAM(LKNT,3)
58088 C...Calculate width.
58089                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58090      &               IDLAM(LKNT,3),XLAM(LKNT))
58091                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58092 C...Charge conjugate mode.
58093                 LKNT=LKNT+1
58094                 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58095                 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58096                 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58097                 XLAM(LKNT)=XLAM(LKNT-1)
58098 C...KINEMATICS CHECK
58099                 IF (XLAM(LKNT).EQ.0D0) THEN
58100                   LKNT=LKNT-2
58101                 ENDIF
58102               ENDIF
58103   150       CONTINUE
58104           ENDIF
58105         ENDIF
58106       ENDIF
58107  
58108       RETURN
58109       END
58110  
58111 C*********************************************************************
58112  
58113 C...PYRVCH
58114 C...Calculates R-violating chargino decay widths.
58115 C...P. Z. Skands
58116  
58117       SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
58118  
58119 C...Double precision and integer declarations.
58120       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58121       IMPLICIT INTEGER(I-N)
58122 C...Parameter statement to help give large particle numbers.
58123       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58124      &KEXCIT=4000000,KDIMEN=5000000)
58125 C...Commonblocks.
58126       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58127       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58128       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58129       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58130      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58131       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58132 C...Local variables.
58133       DOUBLE PRECISION XLAM(0:400)
58134       INTEGER IDLAM(400,3), PYCOMP
58135 C...Information from main routine to PYRVGW
58136       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58137      &     ,DCMASS,KFR(3)
58138 C...Auxiliary variables needed for BV (RV Gauge STOre)
58139       COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58140      &     ,RVLJKI,RVLJIK
58141 C...Running quark masses
58142       DOUBLE PRECISION RMQ(6)
58143 C...Decay product masses on/off
58144       LOGICAL DCMASS
58145       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58146      &     /RVGSTO/
58147  
58148  
58149 C...IF R-VIOLATION ON.
58150       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
58151         KFSM=KFIN-KSUSY1
58152         IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
58153 C...WHICH CHARGINO ?
58154           NCHI = 1
58155           IF (KFSM.EQ.37) NCHI = 2
58156  
58157 C...Useful parameters for calculating the A and B constants.
58158 C...SIGN OF MASS (Opposite convention as HERWIG)
58159           ISM  = 1
58160           IF (SMW(NCHI).LT.0D0) ISM = -1
58161           WMASS   = PMAS(PYCOMP(24),1)
58162           COSB    = 1/(SQRT(1+RMSS(5)**2))
58163           SINB    = RMSS(5)/SQRT(1+RMSS(5)**2)
58164           GW2     = 4*PARU(103)*PARU(1)/PARU(102)
58165           C1U     = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
58166           C1V     = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
58167           C2      = UMIX(NCHI,1)
58168           C3      = VMIX(NCHI,1)
58169 C...Running masses at Q^2=MCHI^2.
58170           SQMCHI  = PMAS(PYCOMP(KFSM),1)**2
58171           DO 100 I=1,6
58172             RMQ(I)=PYMRUN(I,SQMCHI)
58173   100     CONTINUE
58174  
58175 C... AB(x,y,z) coefficients:
58176 C       x=1-2  : A or B coefficient  (1:A ; 2:B)
58177 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58178 C                                    11-16:e,nu_e,mu,...)
58179 C       z=1-2  : Mass eigenstate number
58180           DO 110 I = 11,15,2
58181 C...Intermediate sleptons
58182             AB(1,I,1)   = 0D0
58183             AB(1,I,2)   = 0D0
58184             AB(2,I,1)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
58185      &           SFMIX(I,1)*C2
58186             AB(2,I,2)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
58187      &           SFMIX(I,3)*C2
58188 C...Intermediate sneutrinos
58189             AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
58190             AB(1,I+1,2) = 0D0
58191             AB(2,I+1,1) = ISM*C3
58192             AB(2,I+1,2) = 0D0
58193 C...Intermediate sdown
58194             J=I-10
58195             AB(1,J,1)   = -RMQ(J+1)*C1V*SFMIX(J,1)
58196             AB(1,J,2)   = -RMQ(J+1)*C1V*SFMIX(J,3)
58197             AB(2,J,1)   = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
58198             AB(2,J,2)   = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
58199 C...Intermediate sup
58200             J=J+1
58201             AB(1,J,1)   = -RMQ(J-1)*C1U*SFMIX(J,1)
58202             AB(1,J,2)   = -RMQ(J-1)*C1U*SFMIX(J,3)
58203             AB(2,J,1)   = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
58204             AB(2,J,2)   = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
58205   110     CONTINUE
58206  
58207 C...LLE TYPE R-VIOLATION
58208           IF (IMSS(51).GE.1) THEN
58209 C...LOOP OVER DECAY MODES
58210             DO 140 ISC=0,26
58211  
58212 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
58213               IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
58214                 LKNT = LKNT+1
58215                 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
58216                 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
58217                 IDLAM(LKNT,3) =  12 +2*MOD(ISC,3)
58218                 XLAM(LKNT)    =  0D0
58219 C...Set coupling, and decay product masses on/off
58220                 RVLAMC        = GW2 * 5D-1 *
58221      &               RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58222      &               **2
58223                 DCMASS=.FALSE.
58224                 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
58225 C...Resonance KF codes (1=I,2=J,3=K).
58226                 KFR(1) = 0
58227                 KFR(2) = 0
58228                 KFR(3) = -IDLAM(LKNT,3)+1
58229 C...Calculate width.
58230                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58231      &               IDLAM(LKNT,3),XLAM(LKNT))
58232                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58233 C...KINEMATICS CHECK
58234                 IF (XLAM(LKNT).EQ.0D0) THEN
58235                   LKNT=LKNT-1
58236                 ENDIF
58237  
58238 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
58239   120           IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
58240                   LKNT = LKNT+1
58241                   IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58242                   IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
58243                   IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
58244                   XLAM(LKNT)    = 0D0
58245 C...Set coupling, and decay product masses on/off
58246                   RVLAMC = GW2 * 5D-1 *
58247      &              RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58248 C...I,J SYMMETRY => FACTOR 2
58249                   RVLAMC=2*RVLAMC
58250                   DCMASS=.FALSE.
58251                   IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
58252 C...Resonance KF codes (1=I,2=J,3=K)
58253                   KFR(1)=IDLAM(LKNT,1)-1
58254                   KFR(2)=IDLAM(LKNT,2)-1
58255                   KFR(3)=0
58256 C...Calculate width.
58257                   CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58258      &                 IDLAM(LKNT,3),XLAM(LKNT))
58259                  XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58260 C...KINEMATICS CHECK
58261                   IF (XLAM(LKNT).EQ.0D0) THEN
58262                     LKNT=LKNT-1
58263                   ENDIF
58264 
58265 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
58266 C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement 
58267 C *             from above, thanks to N.-E. Bomark.
58268                   LKNT = LKNT+1
58269                   IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58270                   IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
58271                   IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
58272                   XLAM(LKNT)    = 0D0
58273 C...Set coupling, and decay product masses on/off
58274                   RVLAMC = GW2 * 5D-1 *
58275      &              RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58276 C...I,J SYMMETRY => FACTOR 2
58277                   RVLAMC=2*RVLAMC
58278                   DCMASS=.FALSE.
58279                   IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
58280      &                 .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
58281 C...Resonance KF codes (1=I,2=J,3=K)
58282                   KFR(1) =-IDLAM(LKNT,1)+1
58283                   KFR(2) =-IDLAM(LKNT,2)+1
58284                   KFR(3) = 0
58285 C...Calculate width.
58286                   CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58287      &                 IDLAM(LKNT,3),XLAM(LKNT))
58288                   XLAM(LKNT)=XLAM(LKNT)*RVLAMC
58289      &                 /((2*PARU(1)*RMS(0))**3*32)
58290 C...KINEMATICS CHECK
58291                   IF (XLAM(LKNT).EQ.0D0) THEN
58292                     LKNT=LKNT-1
58293                   ENDIF
58294                 ENDIF
58295               ENDIF
58296  140        CONTINUE
58297           ENDIF
58298  
58299 C...LQD TYPE R-VIOLATION
58300           IF (IMSS(52).GE.1) THEN
58301 C...LOOP OVER DECAY MODES
58302             DO 180 ISC=0,26
58303  
58304 C...CHI+ -> NUBAR_I + DBAR_J + U_K
58305               LKNT = LKNT+1
58306               IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58307               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58308               IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
58309               XLAM(LKNT)    =  0D0
58310 C...Set coupling, and decay product masses on/off
58311               RVLAMC = 3. * GW2 * 5D-1 *
58312      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58313               DCMASS=.FALSE.
58314               IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
58315      &             DCMASS = .TRUE.
58316 C...Resonance KF codes (1=I,2=J,3=K)
58317               KFR(1)=0
58318               KFR(2)=0
58319               KFR(3)=-IDLAM(LKNT,3)+1
58320 C...Calculate width.
58321               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58322      &             ,XLAM(LKNT))
58323               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58324 C...KINEMATICS CHECK
58325               IF (XLAM(LKNT).EQ.0D0) THEN
58326                 LKNT=LKNT-1
58327               ENDIF
58328  
58329 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
58330   150         LKNT = LKNT+1
58331               IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58332               IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58333               IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
58334               XLAM(LKNT)    =  0D0
58335 C...Set coupling, and decay product masses on/off
58336               RVLAMC = 3. * GW2 * 5D-1 *
58337      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58338               DCMASS=.FALSE.
58339               IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
58340      &             .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
58341 C...Resonance KF codes (1=I,2=J,3=K)
58342               KFR(1)=0
58343               KFR(2)=0
58344               KFR(3)=-IDLAM(LKNT,3)+1
58345 C...Calculate width.
58346               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58347      &             ,XLAM(LKNT))
58348               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58349 C...KINEMATICS CHECK
58350               IF (XLAM(LKNT).EQ.0D0) THEN
58351                 LKNT=LKNT-1
58352               ENDIF
58353  
58354 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
58355   160         LKNT = LKNT+1
58356               IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58357               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58358               IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58359               XLAM(LKNT)    =  0D0
58360 C...Set coupling, and decay product masses on/off
58361               RVLAMC = 3. * GW2 * 5D-1 *
58362      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58363               DCMASS = .FALSE.
58364               IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
58365      &             .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58366 C...Resonance KF codes (1=I,2=J,3=K)
58367               KFR(1)=-IDLAM(LKNT,1)+1
58368               KFR(2)=-IDLAM(LKNT,2)+1
58369               KFR(3)=0
58370 C...Calculate width.
58371               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58372      &             ,XLAM(LKNT))
58373               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58374 C...KINEMATICS CHECK
58375               IF (XLAM(LKNT).EQ.0D0) THEN
58376                 LKNT=LKNT-1
58377               ENDIF
58378  
58379 C * CHI+ -> NU_I + U_J + DBAR_K.
58380   170         LKNT = LKNT+1
58381               IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58382               IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
58383               IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58384               XLAM(LKNT)    =  0D0
58385 C...Set coupling, and decay product masses on/off
58386               DCMASS = .FALSE.
58387               RVLAMC = 3. * GW2 * 5D-1 *
58388      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58389               IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
58390      &             DCMASS = .TRUE.
58391 C...Resonance KF codes (1=I,2=J,3=K)
58392               KFR(1)=IDLAM(LKNT,1)-1
58393               KFR(2)=IDLAM(LKNT,2)-1
58394               KFR(3)=0
58395 C...Calculate width.
58396               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58397      &             ,XLAM(LKNT))
58398               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58399 C...KINEMATICS CHECK
58400               IF (XLAM(LKNT).EQ.0D0) THEN
58401                 LKNT=LKNT-1
58402               ENDIF
58403  
58404   180       CONTINUE
58405           ENDIF
58406  
58407 C...UDD TYPE R-VIOLATION
58408 C...These decays need special treatment since more than one BV coupling
58409 C...contributes (with interference). Consider e.g. (symbolically)
58410 C      |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
58411 C             +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
58412 C             +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
58413 C...The problem is that a single call to PYRVGW would evaluate all
58414 C...these terms and sum them, but without the different couplings. The
58415 C...way out is to call PYRVGW three times, once for the first line, once
58416 C...for the second line, and then once for all the lines (it is
58417 C...impossible to get just the last line out) without multiplying by
58418 C...couplings. The last line is then obtained as the result of the third
58419 C...call minus the results of the two first calls. Each term is then
58420 C...multiplied by its respective coupling before the whole thing is
58421 C...summed up in XLAM.
58422 C...Note that with three interfering resonances, this procedure becomes
58423 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
58424  
58425           IF (IMSS(53).GE.1) THEN
58426 C...LOOP OVER DECAY MODES
58427             DO 190 ISC=1,25
58428  
58429 C...CHI+ -> U_I + U_J + D_K
58430 C...Decay mode I<->J symmetric.
58431               IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
58432                 LKNT = LKNT+1
58433                 IDLAM(LKNT,1) =  2 +2*MOD(ISC/9,3)
58434                 IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
58435                 IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58436                 XLAM(LKNT)    =  0D0
58437 C...Set coupling, and decay product masses on/off
58438                 RVLAMC= 6. * GW2 * 5D-1
58439                 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
58440      &               +1)
58441                 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58442      &               +1)
58443                 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
58444      &               * RVLAMC
58445                 DCMASS=.FALSE.
58446                 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
58447      &               .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
58448 C...Resonance KF codes (1=I,2=J,3=K)
58449                 KFR(1) = -IDLAM(LKNT,1)+1
58450                 KFR(2) = 0
58451                 KFR(3) = 0
58452 C...Calculate width.
58453                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58454      &               IDLAM(LKNT,3),XRESI)
58455 C...Resonance KF codes (1=I,2=J,3=K)
58456                 KFR(1) = 0
58457                 KFR(2) = -IDLAM(LKNT,2)+1
58458                 KFR(3) = 0
58459 C...Calculate width.
58460                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58461      &               IDLAM(LKNT,3),XRESJ)
58462 C...Resonance KF codes (1=I,2=J,3=K)
58463                 KFR(1) = -IDLAM(LKNT,1)+1
58464                 KFR(2) = -IDLAM(LKNT,2)+1
58465                 KFR(3) = 0
58466 C...Calculate width.
58467                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58468      &               IDLAM(LKNT,3),XRESIJ)
58469                 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58470                   XRESIJ = XRESIJ-XRESI-XRESJ
58471                 ELSE
58472                   XRESIJ = 0D0
58473                 ENDIF
58474 C...CALCULATE TOTAL WIDTH
58475                 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
58476      &               + RVLJIK*RVLIJK * XRESIJ
58477                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58478 C...KINEMATICS CHECK
58479                 IF (XLAM(LKNT).EQ.0D0) THEN
58480                   LKNT=LKNT-1
58481                 ENDIF
58482               ENDIF
58483 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
58484 C...Symmetry I<->J<->K.
58485               IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
58486      &             .MOD(ISC,3)).AND.ISC.NE.13) THEN
58487                 LKNT = LKNT+1
58488                 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
58489                 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58490                 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58491                 XLAM(LKNT)    =  0D0
58492 C...Set coupling, and decay product masses on/off
58493                 RVLAMC = 6. * GW2 * 5D-1
58494                 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58495      &               +1)
58496                 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
58497      &               +1)
58498                 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
58499      &               +1)
58500                 DCMASS = .FALSE.
58501                 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
58502      &               .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
58503 C...Collect symmetry factors
58504                 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
58505      &               .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
58506      &               RVLAMC = 5D-1 * RVLAMC
58507 C...Resonance KF codes (1=I,2=J,3=K)
58508                 KFR(1) = IDLAM(LKNT,1)-1
58509                 KFR(2) = 0
58510                 KFR(3) = 0
58511 C...Calculate width.
58512                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58513      &               IDLAM(LKNT,3),XRESI)
58514 C...Resonance KF codes (1=I,2=J,3=K)
58515                 KFR(1) = 0
58516                 KFR(2) = IDLAM(LKNT,2)-1
58517                 KFR(3) = 0
58518 C...Calculate width.
58519                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58520      &               IDLAM(LKNT,3),XRESJ)
58521 C...Resonance KF codes (1=I,2=J,3=K)
58522                 KFR(1) = 0
58523                 KFR(2) = 0
58524                 KFR(3) = IDLAM(LKNT,3)-1
58525 C...Calculate width.
58526                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58527      &               IDLAM(LKNT,3),XRESK)
58528 C...Resonance KF codes (1=I,2=J,3=K)
58529                 KFR(1) = IDLAM(LKNT,1)-1
58530                 KFR(2) = IDLAM(LKNT,2)-1
58531                 KFR(3) = 0
58532 C...Calculate width.
58533                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58534      &               IDLAM(LKNT,3),XRESIJ)
58535                 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
58536                   XRESIJ = XRESI+XRESJ-XRESIJ
58537                 ELSE
58538                   XRESIJ = 0D0
58539                 ENDIF
58540 C...Resonance KF codes (1=I,2=J,3=K)
58541                 KFR(1) = 0
58542                 KFR(2) = IDLAM(LKNT,2)-1
58543                 KFR(3) = IDLAM(LKNT,3)-1
58544 C...Calculate width.
58545                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58546      &               IDLAM(LKNT,3),XRESJK)
58547                 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
58548                   XRESJK = XRESJ+XRESK-XRESJK
58549                 ELSE
58550                   XRESJK = 0D0
58551                 ENDIF
58552 C...Resonance KF codes (1=I,2=J,3=K)
58553                 KFR(1) = IDLAM(LKNT,1)-1
58554                 KFR(2) = 0
58555                 KFR(3) = IDLAM(LKNT,3)-1
58556 C...Calculate width.
58557                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58558      &               IDLAM(LKNT,3),XRESIK)
58559                 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
58560                   XRESIK = XRESI+XRESK-XRESIK
58561                 ELSE
58562                   XRESIK = 0D0
58563                 ENDIF
58564 C...CALCULATE TOTAL WIDTH
58565                 XLAM(LKNT) =
58566      &                 RVLIJK**2 * XRESI
58567      &               + RVLJKI**2 * XRESJ
58568      &               + RVLKIJ**2 * XRESK
58569      &               + RVLIJK*RVLJKI * XRESIJ
58570      &               + RVLIJK*RVLKIJ * XRESIK
58571      &               + RVLJKI*RVLKIJ * XRESJK
58572                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
58573 C...KINEMATICS CHECK
58574                 IF (XLAM(LKNT).EQ.0D0) THEN
58575                   LKNT=LKNT-1
58576                 ENDIF
58577               ENDIF
58578   190       CONTINUE
58579           ENDIF
58580         ENDIF
58581       ENDIF
58582  
58583       RETURN
58584       END
58585  
58586 C*********************************************************************
58587  
58588 C...PYRVGL
58589 C...Calculates R-violating gluino decay widths.
58590 C...See BV part of PYRVCH for comments about the way the BV decay width
58591 C...is calculated. Same comments apply here.
58592 C...P. Z. Skands
58593  
58594       SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
58595  
58596 C...Double precision and integer declarations.
58597       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58598       IMPLICIT INTEGER(I-N)
58599 C...Parameter statement to help give large particle numbers.
58600       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58601      &KEXCIT=4000000,KDIMEN=5000000)
58602 C...Commonblocks.
58603       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58604       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58605       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58606       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58607      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58608       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58609 C...Local variables.
58610       DOUBLE PRECISION XLAM(0:400)
58611       INTEGER IDLAM(400,3), PYCOMP
58612 C...Information from main routine to PYRVGW
58613       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58614      &     ,DCMASS,KFR(3)
58615 C...Auxiliary variables needed for BV (RV Gauge STOre)
58616       COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58617      &     ,RVLJKI,RVLJIK
58618 C...Running quark masses
58619       DOUBLE PRECISION RMQ(6)
58620 C...Decay product masses on/off
58621       LOGICAL DCMASS
58622       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58623      &     /RVGSTO/
58624  
58625 C...IF LQD OR UDD TYPE R-VIOLATION ON.
58626       IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
58627         KFSM=KFIN-KSUSY1
58628  
58629 C... AB(x,y,z):
58630 C       x=1-2  : Select A or B coupling     (1:A ; 2:B)
58631 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58632 C                                    11-16:e,nu_e,mu,... not used here)
58633 C       z=1-2  : Mass eigenstate number
58634         DO 100 I = 1,6
58635 C...A Couplings
58636           AB(1,I,1) = SFMIX(I,2)
58637           AB(1,I,2) = SFMIX(I,4)
58638 C...B Couplings
58639           AB(2,I,1) = -SFMIX(I,1)
58640           AB(2,I,2) = -SFMIX(I,3)
58641   100   CONTINUE
58642         GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
58643 C...LQD DECAYS.
58644         IF (IMSS(52).GE.1) THEN
58645 C...STEP IN I,J,K USING SINGLE COUNTER
58646           DO 120 ISC=0,26
58647 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
58648             LKNT          = LKNT+1
58649             IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58650             IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58651             IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58652             XLAM(LKNT)=0D0
58653 C...Set coupling, and decay product masses on/off
58654             RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58655      &           * 5D-1 * GSTR2
58656             DCMASS        = .FALSE.
58657             IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58658 C...Resonance KF codes (1=I,2=J,3=K)
58659             KFR(1)        = 0
58660             KFR(2)        = -IDLAM(LKNT,2)
58661             KFR(3)        = -IDLAM(LKNT,3)
58662 C...Calculate width.
58663             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58664      &           ,XLAM(LKNT))
58665 C...Normalize
58666             XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58667 C...Charge conjugate mode.
58668   110       LKNT          = LKNT+1
58669             IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58670             IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58671             IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58672             XLAM(LKNT)    = XLAM(LKNT-1)
58673 C...KINEMATICS CHECK
58674             IF (XLAM(LKNT).EQ.0D0) THEN
58675               LKNT=LKNT-2
58676             ENDIF
58677  
58678 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
58679             LKNT = LKNT+1
58680             IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58681             IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58682             IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
58683             XLAM(LKNT)=0D0
58684 C...Set coupling, and decay product masses on/off
58685             RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58686      &           **2* 5D-1 * GSTR2
58687             DCMASS        = .FALSE.
58688             IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58689      &           .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58690 C...Resonance KF codes (1=I,2=J,3=K)
58691             KFR(1)        = 0
58692             KFR(2)        = -IDLAM(LKNT,2)
58693             KFR(3)        = -IDLAM(LKNT,3)
58694 C...Calculate width.
58695             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58696      &           ,XLAM(LKNT))
58697             XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58698 C...Charge conjugate mode.
58699             LKNT=LKNT+1
58700             IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
58701             IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
58702             IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
58703             XLAM(LKNT)    =  XLAM(LKNT-1)
58704 C...KINEMATICS CHECK
58705             IF (XLAM(LKNT).EQ.0D0) THEN
58706               LKNT=LKNT-2
58707             ENDIF
58708  
58709   120     CONTINUE
58710         ENDIF
58711  
58712 C...UDD DECAYS.
58713         IF (IMSS(53).GE.1) THEN
58714 C...STEP IN I,J,K USING SINGLE COUNTER
58715           DO 130 ISC=0,26
58716 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
58717             IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58718               LKNT          = LKNT+1
58719               IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58720               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58721               IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58722               XLAM(LKNT)=0D0
58723 C...Set coupling, and decay product masses on/off. A factor of 2 for
58724 C...(N_C-1) has been used to cancel a factor 0.5.
58725               RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58726      &             **2 * GSTR2
58727               DCMASS        = .FALSE.
58728               IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58729      &             .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58730 C...Resonance KF codes (1=I,2=J,3=K)
58731               KFR(1)        = IDLAM(LKNT,1)
58732               KFR(2)        = 0
58733               KFR(3)        = 0
58734 C...Calculate width.
58735               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58736      &             ,XRESI)
58737 C...Resonance KF codes (1=I,2=J,3=K)
58738               KFR(1)        = 0
58739               KFR(2)        = IDLAM(LKNT,2)
58740               KFR(3)        = 0
58741 C...Calculate width.
58742               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58743      &             ,XRESJ)
58744 C...Resonance KF codes (1=I,2=J,3=K)
58745               KFR(1)        = 0
58746               KFR(2)        = 0
58747               KFR(3)        = IDLAM(LKNT,3)
58748 C...Calculate width.
58749               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58750      &             ,XRESK)
58751 C...Resonance KF codes (1=I,2=J,3=K)
58752               KFR(1)        = IDLAM(LKNT,1)
58753               KFR(2)        = IDLAM(LKNT,2)
58754               KFR(3)        = 0
58755 C...Calculate width.
58756               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58757      &             ,XRESIJ)
58758 C...Calculate interference function. (Factor -1/2 to make up for factor
58759 C...-2 in PYRVGW.
58760               IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58761                 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
58762               ELSE
58763                 XRESIJ = 0D0
58764               ENDIF
58765 C...Resonance KF codes (1=I,2=J,3=K)
58766               KFR(1)        = 0
58767               KFR(2)        = IDLAM(LKNT,2)
58768               KFR(3)        = IDLAM(LKNT,3)
58769 C...Calculate width.
58770               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58771      &             ,XRESJK)
58772               IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
58773                 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
58774               ELSE
58775                 XRESJK = 0D0
58776               ENDIF
58777 C...Resonance KF codes (1=I,2=J,3=K)
58778               KFR(1)        = IDLAM(LKNT,1)
58779               KFR(2)        = 0
58780               KFR(3)        = IDLAM(LKNT,3)
58781 C...Calculate width.
58782               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58783      &             ,XRESIK)
58784               IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
58785                 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
58786               ELSE
58787                 XRESIK = 0D0
58788               ENDIF
58789 C...Calculate total width (factor 1/2 from 1/(N_C-1))
58790               XLAM(LKNT) = XRESI + XRESJ + XRESK
58791      &             + 5D-1 * (XRESIJ + XRESIK + XRESJK)
58792 C...Normalize
58793               XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58794 C...Charge conjugate mode.
58795               LKNT          = LKNT+1
58796               IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58797               IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58798               IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58799               XLAM(LKNT)    = XLAM(LKNT-1)
58800 C...KINEMATICS CHECK
58801               IF (XLAM(LKNT).EQ.0D0) THEN
58802                 LKNT=LKNT-2
58803               ENDIF
58804             ENDIF
58805   130     CONTINUE
58806         ENDIF
58807       ENDIF
58808       RETURN
58809       END
58810  
58811 C*********************************************************************
58812  
58813 C...PYRVSB
58814 C...Auxiliary function to PYRVSF for calculating R-Violating
58815 C...sfermion widths. Though the decay products are most often treated
58816 C...as massless in the calculation, the kinematical boundary of phase
58817 C...space is tested using the true masses.
58818 C...MODE = 1: All decay products massive
58819 C...MODE = 2: Decay product 1 massless
58820 C...MODE = 3: Decay product 2 massless
58821 C...MODE = 4: All decay products  massless
58822  
58823       FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
58824  
58825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58826       IMPLICIT INTEGER (I-N)
58827       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58828       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58829       SAVE /PYDAT1/,/PYDAT2/
58830       DOUBLE PRECISION SM(3)
58831       INTEGER PYCOMP, KC(3)
58832       KC(1)=PYCOMP(KFIN)
58833       KC(2)=PYCOMP(ID1)
58834       KC(3)=PYCOMP(ID2)
58835       SM(1)=PMAS(KC(1),1)**2
58836       SM(2)=PMAS(KC(2),1)**2
58837       SM(3)=PMAS(KC(3),1)**2
58838 C...Kinematics check
58839       IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
58840         PYRVSB=0D0
58841         RETURN
58842       ENDIF
58843 C...CM momenta squared
58844       IF (MODE.EQ.1) THEN
58845         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58846      &       * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58847       ELSE IF (MODE.EQ.2) THEN
58848         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58849       ELSE IF (MODE.EQ.3) THEN
58850         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58851       ELSE
58852         P2CM=SM(1)/4.
58853       ENDIF
58854 C...Calculate Width
58855       PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58856       RETURN
58857       END
58858  
58859 C*********************************************************************
58860  
58861 C...PYRVGW
58862 C...Generalized Matrix Element for R-Violating 3-body widths.
58863 C...P. Z. Skands
58864       SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58865  
58866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58867       IMPLICIT INTEGER (I-N)
58868       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58869      &KEXCIT=4000000,KDIMEN=5000000)
58870       PARAMETER (EPS=1D-4)
58871       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58872       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58873      &     ,DCMASS,KFR(3)
58874       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58875      & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58876       DOUBLE PRECISION XLIM(3,3)
58877       INTEGER KC(0:3), PYCOMP
58878       LOGICAL DCMASS, DCHECK(6)
58879       SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58880  
58881       XLAM   = 0D0
58882  
58883       KC(0)  = PYCOMP(KFIN)
58884       KC(1)  = PYCOMP(ID1)
58885       KC(2)  = PYCOMP(ID2)
58886       KC(3)  = PYCOMP(ID3)
58887       RMS(0) = PMAS(KC(0),1)
58888       RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58889       RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58890       RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58891 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58892       XLIM(1,1)=(RMS(1)+RMS(2))**2
58893       XLIM(1,2)=(RMS(0)-RMS(3))**2
58894       XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58895       XLIM(2,1)=(RMS(2)+RMS(3))**2
58896       XLIM(2,2)=(RMS(0)-RMS(1))**2
58897       XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58898       XLIM(3,1)=(RMS(1)+RMS(3))**2
58899       XLIM(3,2)=(RMS(0)-RMS(2))**2
58900       XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58901 C...Check Phase Space
58902       IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58903         RETURN
58904       ENDIF
58905  
58906 C...INITIALIZE RESONANCE INFORMATION
58907       DO 110 JRES = 1,3
58908         DO 100 IMASS = 1,2
58909           IRES = 2*(JRES-1)+IMASS
58910           INTRES(IRES,1) = 0
58911           DCHECK(IRES)   =.FALSE.
58912 C...NO RIGHT-HANDED NEUTRINOS
58913           IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58914      &         .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58915      &         .KFR(JRES).EQ.0) GOTO 100
58916           RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58917           RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58918           INTRES(IRES,1) = IABS(KFR(JRES))
58919           INTRES(IRES,2) = IMASS
58920           IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58921           IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58922   100   CONTINUE
58923   110 CONTINUE
58924  
58925 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58926  
58927 C...RESONANCE CONTRIBUTIONS
58928 C...(Only sum contributions where the resonance is off shell).
58929 C...Store whether diagram on/off in DCHECK.
58930 C...LOOP OVER MASS STATES
58931       DO 120 J=1,2
58932         IDR=J
58933         IF(INTRES(IDR,1).NE.0) THEN
58934 
58935         TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58936         IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58937      &       +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58938           DCHECK(IDR) =.TRUE.
58939           XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58940         ENDIF
58941         ENDIF
58942  
58943         IDR=J+2
58944         IF(INTRES(IDR,1).NE.0) THEN
58945         TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58946         IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58947      &       +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58948           DCHECK(IDR) =.TRUE.
58949           XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58950         ENDIF
58951         ENDIF
58952  
58953         IDR=J+4
58954         IF(INTRES(IDR,1).NE.0) THEN
58955         TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58956         IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58957      &       +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58958           DCHECK(IDR) =.TRUE.
58959           XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58960         ENDIF
58961         ENDIF
58962   120 CONTINUE
58963 C... L-R INTERFERENCES
58964 C... (Only add contributions where both contributing diagrams
58965 C... are non-resonant).
58966       IDR=1
58967       IF (DCHECK(1).AND.DCHECK(2)) THEN
58968 C...Bug corrected 11/12 2001. Skands.
58969         XLAM  = XLAM + 2D0 * PYRVI2(2,3,1)
58970      &     * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58971      &     * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58972       ENDIF
58973  
58974       IDR=3
58975       IF (DCHECK(3).AND.DCHECK(4)) THEN
58976         XLAM  = XLAM + 2D0 * PYRVI2(1,3,2)
58977      &     * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58978      &     * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58979       ENDIF
58980  
58981       IDR=5
58982       IF (DCHECK(5).AND.DCHECK(6)) THEN
58983         XLAM  = XLAM + 2D0 * PYRVI2(1,2,3)
58984      &     * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58985      &     * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58986       ENDIF
58987 C... TRUE INTERFERENCES
58988 C... (Only add contributions where both contributing diagrams
58989 C... are non-resonant).
58990       PREF=-2D0
58991       IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58992       DO 140 IKR1 = 1,2
58993         DO 130 IKR2 = 1,2
58994           IDR  = IKR1+2
58995           IDR2 = IKR2
58996           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58997             XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58998      &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58999      &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
59000           ENDIF
59001  
59002           IDR  = IKR1+4
59003           IDR2 = IKR2
59004           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
59005             XLAM = XLAM + PREF*PYRVI3(1,2,3) *
59006      &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
59007      &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
59008           ENDIF
59009  
59010           IDR  = IKR1+4
59011           IDR2 = IKR2+2
59012           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
59013             XLAM = XLAM + PREF*PYRVI3(2,1,3) *
59014      &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
59015      &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
59016           ENDIF
59017   130   CONTINUE
59018   140 CONTINUE
59019  
59020       RETURN
59021       END
59022  
59023 C*********************************************************************
59024  
59025 C...PYRVI1
59026 C...Function to integrate resonance contributions
59027  
59028       FUNCTION PYRVI1(ID1,ID2,ID3)
59029  
59030       IMPLICIT NONE
59031       DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
59032       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59033       INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59034       LOGICAL MFLAG,DCMASS
59035       EXTERNAL PYRVG1,PYGAUS
59036       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59037      &     ,DCMASS,KFR(3)
59038       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59039       SAVE/PYRVNV/,/PYRVPM/
59040 C...Initialize mass and width information
59041       PYRVI1 = 0D0
59042       RM(0)  = RMS(0)
59043       RM(1)  = RMS(ID1)
59044       RM(2)  = RMS(ID2)
59045       RM(3)  = RMS(ID3)
59046       RESM(1)= RES(IDR,1)
59047       RESW(1)= RES(IDR,2)
59048 C...A->B and B->A for antisparticles
59049       A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59050       B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59051 C...Integration boundaries and mass flag
59052       LO     = (RM(1)+RM(2))**2
59053       HI     = (RM(0)-RM(3))**2
59054       MFLAG  = DCMASS
59055       PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
59056       RETURN
59057       END
59058  
59059 C*********************************************************************
59060  
59061 C...PYRVI2
59062 C...Function to integrate L-R interference contributions
59063  
59064       FUNCTION PYRVI2(ID1,ID2,ID3)
59065  
59066       IMPLICIT NONE
59067       DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
59068       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59069       INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59070       LOGICAL MFLAG,DCMASS
59071       EXTERNAL PYRVG2,PYGAUS
59072       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59073      &     ,DCMASS,KFR(3)
59074       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59075       SAVE/PYRVNV/,/PYRVPM/
59076 C...Initialize mass and width information
59077       PYRVI2 = 0D0
59078       RM(0)  = RMS(0)
59079       RM(1)  = RMS(ID1)
59080       RM(2)  = RMS(ID2)
59081       RM(3)  = RMS(ID3)
59082       RESM(1)= RES(IDR,1)
59083       RESW(1)= RES(IDR,2)
59084       RESM(2)= RES(IDR+1,1)
59085       RESW(2)= RES(IDR+1,2)
59086 C...A->B and B->A for antisparticles
59087       A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59088       B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59089       A(2)   = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59090       B(2)   = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59091 C...Boundaries and mass flag
59092       LO     = (RM(1)+RM(2))**2
59093       HI     = (RM(0)-RM(3))**2
59094       MFLAG  = DCMASS
59095       PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
59096       RETURN
59097       END
59098  
59099 C*********************************************************************
59100  
59101 C...PYRVI3
59102 C...Function to integrate true interference contributions
59103  
59104       FUNCTION PYRVI3(ID1,ID2,ID3)
59105  
59106       IMPLICIT NONE
59107       DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
59108       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59109       INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59110       LOGICAL MFLAG,DCMASS
59111       EXTERNAL PYRVG3,PYGAUS
59112       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59113      &     ,DCMASS,KFR(3)
59114       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59115       SAVE/PYRVNV/,/PYRVPM/
59116 C...Initialize mass and width information
59117       PYRVI3 = 0D0
59118       RM(0)  = RMS(0)
59119       RM(1)  = RMS(ID1)
59120       RM(2)  = RMS(ID2)
59121       RM(3)  = RMS(ID3)
59122       RESM(1)= RES(IDR,1)
59123       RESW(1)= RES(IDR,2)
59124       RESM(2)= RES(IDR2,1)
59125       RESW(2)= RES(IDR2,2)
59126 C...A -> B and B -> A for antisparticles
59127       A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59128       B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59129       A(2)   = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59130       B(2)   = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59131 C...Boundaries and mass flag
59132       LO     = (RM(1)+RM(2))**2
59133       HI     = (RM(0)-RM(3))**2
59134       MFLAG  = DCMASS
59135       PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
59136       RETURN
59137       END
59138  
59139 C*********************************************************************
59140  
59141 C...PYRVG1
59142 C...Integrand for resonance contributions
59143  
59144       FUNCTION PYRVG1(X)
59145  
59146       IMPLICIT NONE
59147       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59148       DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
59149       DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
59150       LOGICAL MFLAG
59151       SAVE/PYRVPM/
59152       RVR    = PYRVR(X,RESM(1),RESW(1))
59153       C1     = 2D0*SQRT(MAX(0D0,X))
59154       IF (.NOT.MFLAG) THEN
59155         E2     = X/C1
59156         E3     = (RM(0)**2-X)/C1
59157         DELTAY = 4D0*E2*E3
59158         PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
59159       ELSE
59160         E2     = (X-RM(1)**2+RM(2)**2)/C1
59161         E3     = (RM(0)**2-X-RM(3)**2)/C1
59162         SR1    = SQRT(MAX(0D0,E2**2-RM(2)**2))
59163         SR2    = SQRT(MAX(0D0,E3**2-RM(3)**2))
59164         DELTAY = 4D0*SR1*SR2
59165         A1     = 4.*A(1)*B(1)*RM(3)*RM(0)
59166         A2     = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
59167         PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
59168       ENDIF
59169       RETURN
59170       END
59171  
59172 C*********************************************************************
59173  
59174 C...PYRVG2
59175 C...Integrand for L-R interference contributions
59176  
59177       FUNCTION PYRVG2(X)
59178  
59179       IMPLICIT NONE
59180       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59181       DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
59182       DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
59183       LOGICAL MFLAG
59184       SAVE/PYRVPM/
59185       C1     = 2D0*SQRT(MAX(0D0,X))
59186       RVS    = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
59187       IF (.NOT.MFLAG) THEN
59188         E2     = X/C1
59189         E3     = (RM(0)**2-X)/C1
59190         DELTAY = 4D0*E2*E3
59191         PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
59192       ELSE
59193         E2     = (X-RM(1)**2+RM(2)**2)/C1
59194         E3     = (RM(0)**2-X-RM(3)**2)/C1
59195         SR1    = SQRT(MAX(0D0,E2**2-RM(2)**2))
59196         SR2    = SQRT(MAX(0D0,E3**2-RM(3)**2))
59197         DELTAY = 4D0*SR1*SR2
59198         PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
59199      &       + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
59200      &       + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
59201       ENDIF
59202       RETURN
59203       END
59204  
59205 C*********************************************************************
59206  
59207 C...PYRVG3
59208 C...Function to do Y integration over true interference contributions
59209  
59210       FUNCTION PYRVG3(X)
59211  
59212       IMPLICIT NONE
59213       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59214 C...Second Dalitz variable for PYRVG4
59215       COMMON/PYG2DX/X1
59216       DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
59217       DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
59218       DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
59219       LOGICAL MFLAG
59220       EXTERNAL PYGAU2,PYRVG4
59221       SAVE/PYRVPM/,/PYG2DX/
59222       PYRVG3=0D0
59223       C1=2D0*SQRT(MAX(1D-9,X))
59224       X1=X
59225       IF (.NOT.MFLAG) THEN
59226         E2    = X/C1
59227         E3    = (RM(0)**2-X)/C1
59228         YMIN  = 0D0
59229         YMAX  = 4D0*E2*E3
59230       ELSE
59231         E2    = (X-RM(1)**2+RM(2)**2)/C1
59232         E3    = (RM(0)**2-X-RM(3)**2)/C1
59233         SQ1   = (E2+E3)**2
59234         SR1   = SQRT(MAX(0D0,E2**2-RM(2)**2))
59235         SR2   = SQRT(MAX(0D0,E3**2-RM(3)**2))
59236         YMIN  = SQ1-(SR1+SR2)**2
59237         YMAX  = SQ1-(SR1-SR2)**2
59238       ENDIF
59239       PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
59240       RETURN
59241       END
59242  
59243 C*********************************************************************
59244  
59245 C...PYRVG4
59246 C...Integrand for true intereference contributions
59247  
59248       FUNCTION PYRVG4(Y)
59249  
59250       IMPLICIT NONE
59251       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59252       COMMON/PYG2DX/X
59253       DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
59254       LOGICAL MFLAG
59255       SAVE /PYRVPM/,/PYG2DX/
59256       PYRVG4=0D0
59257       RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
59258       IF (.NOT.MFLAG) THEN
59259         PYRVG4 = RVS*B(1)*B(2)*X*Y
59260       ELSE
59261         PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
59262      &       + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
59263      &       + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
59264      &       + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
59265       ENDIF
59266       RETURN
59267       END
59268  
59269 C*********************************************************************
59270  
59271 C...PYRVR
59272 C...Breit-Wigner for resonance contributions
59273  
59274       FUNCTION PYRVR(Mab2,RM,RW)
59275  
59276       IMPLICIT NONE
59277       DOUBLE PRECISION Mab2,RM,RW,PYRVR
59278       PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
59279       RETURN
59280       END
59281  
59282 C*********************************************************************
59283  
59284 C...PYRVS
59285 C...Interference function
59286  
59287       FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
59288  
59289       IMPLICIT NONE
59290       DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
59291       PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
59292      &     +W1*W2*M1*M2)
59293       RETURN
59294       END
59295  
59296 C*********************************************************************
59297  
59298 C...PY1ENT
59299 C...Stores one parton/particle in commonblock PYJETS.
59300  
59301       SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
59302  
59303 C...Double precision and integer declarations.
59304       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59305       IMPLICIT INTEGER(I-N)
59306       INTEGER PYK,PYCHGE,PYCOMP
59307 C...Commonblocks.
59308       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59309       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59310       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59311       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59312  
59313 C...Standard checks.
59314       MSTU(28)=0
59315       IF(MSTU(12).NE.12345) CALL PYLIST(0)
59316       IPA=MAX(1,IABS(IP))
59317       IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
59318      &'(PY1ENT:) writing outside PYJETS memory')
59319       KC=PYCOMP(KF)
59320       IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
59321  
59322 C...Find mass. Reset K, P and V vectors.
59323       PM=0D0
59324       IF(MSTU(10).EQ.1) PM=P(IPA,5)
59325       IF(MSTU(10).GE.2) PM=PYMASS(KF)
59326       DO 100 J=1,5
59327         K(IPA,J)=0
59328         P(IPA,J)=0D0
59329         V(IPA,J)=0D0
59330   100 CONTINUE
59331  
59332 C...Store parton/particle in K and P vectors.
59333       K(IPA,1)=1
59334       IF(IP.LT.0) K(IPA,1)=2
59335       K(IPA,2)=KF
59336       P(IPA,5)=PM
59337       P(IPA,4)=MAX(PE,PM)
59338       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
59339       P(IPA,1)=PA*SIN(THE)*COS(PHI)
59340       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
59341       P(IPA,3)=PA*COS(THE)
59342  
59343 C...Set N. Optionally fragment/decay.
59344       N=IPA
59345       IF(IP.EQ.0) CALL PYEXEC
59346  
59347       RETURN
59348       END
59349  
59350 C*********************************************************************
59351  
59352 C...PY2ENT
59353 C...Stores two partons/particles in their CM frame,
59354 C...with the first along the +z axis.
59355  
59356       SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
59357  
59358 C...Double precision and integer declarations.
59359       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59360       IMPLICIT INTEGER(I-N)
59361       INTEGER PYK,PYCHGE,PYCOMP
59362 C...Commonblocks.
59363       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59364       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59365       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59366       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59367  
59368 C...Standard checks.
59369       MSTU(28)=0
59370       IF(MSTU(12).NE.12345) CALL PYLIST(0)
59371       IPA=MAX(1,IABS(IP))
59372       IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
59373      &'(PY2ENT:) writing outside PYJETS memory')
59374       KC1=PYCOMP(KF1)
59375       KC2=PYCOMP(KF2)
59376       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
59377      &'(PY2ENT:) unknown flavour code')
59378  
59379 C...Find masses. Reset K, P and V vectors.
59380       PM1=0D0
59381       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59382       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59383       PM2=0D0
59384       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59385       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59386       DO 110 I=IPA,IPA+1
59387         DO 100 J=1,5
59388           K(I,J)=0
59389           P(I,J)=0D0
59390           V(I,J)=0D0
59391   100   CONTINUE
59392   110 CONTINUE
59393  
59394 C...Check flavours.
59395       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59396       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59397       IF(MSTU(19).EQ.1) THEN
59398         MSTU(19)=0
59399       ELSE
59400         IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
59401      &  '(PY2ENT:) unphysical flavour combination')
59402       ENDIF
59403       K(IPA,2)=KF1
59404       K(IPA+1,2)=KF2
59405  
59406 C...Store partons/particles in K vectors for normal case.
59407       IF(IP.GE.0) THEN
59408         K(IPA,1)=1
59409         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
59410         K(IPA+1,1)=1
59411  
59412 C...Store partons in K vectors for parton shower evolution.
59413       ELSE
59414         K(IPA,1)=3
59415         K(IPA+1,1)=3
59416         K(IPA,4)=MSTU(5)*(IPA+1)
59417         K(IPA,5)=K(IPA,4)
59418         K(IPA+1,4)=MSTU(5)*IPA
59419         K(IPA+1,5)=K(IPA+1,4)
59420       ENDIF
59421  
59422 C...Check kinematics and store partons/particles in P vectors.
59423       IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
59424      &'(PY2ENT:) energy smaller than sum of masses')
59425       PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
59426      &(2D0*PECM)
59427       P(IPA,3)=PA
59428       P(IPA,4)=SQRT(PM1**2+PA**2)
59429       P(IPA,5)=PM1
59430       P(IPA+1,3)=-PA
59431       P(IPA+1,4)=SQRT(PM2**2+PA**2)
59432       P(IPA+1,5)=PM2
59433  
59434 C...Set N. Optionally fragment/decay.
59435       N=IPA+1
59436       IF(IP.EQ.0) CALL PYEXEC
59437  
59438       RETURN
59439       END
59440  
59441 C*********************************************************************
59442  
59443 C...PY3ENT
59444 C...Stores three partons or particles in their CM frame,
59445 C...with the first along the +z axis and the third in the (x,z)
59446 C...plane with x > 0.
59447  
59448       SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
59449  
59450 C...Double precision and integer declarations.
59451       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59452       IMPLICIT INTEGER(I-N)
59453       INTEGER PYK,PYCHGE,PYCOMP
59454 C...Commonblocks.
59455       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59456       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59457       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59458       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59459  
59460 C...Standard checks.
59461       MSTU(28)=0
59462       IF(MSTU(12).NE.12345) CALL PYLIST(0)
59463       IPA=MAX(1,IABS(IP))
59464       IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
59465      &'(PY3ENT:) writing outside PYJETS memory')
59466       KC1=PYCOMP(KF1)
59467       KC2=PYCOMP(KF2)
59468       KC3=PYCOMP(KF3)
59469       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
59470      &'(PY3ENT:) unknown flavour code')
59471  
59472 C...Find masses. Reset K, P and V vectors.
59473       PM1=0D0
59474       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59475       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59476       PM2=0D0
59477       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59478       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59479       PM3=0D0
59480       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59481       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59482       DO 110 I=IPA,IPA+2
59483         DO 100 J=1,5
59484           K(I,J)=0
59485           P(I,J)=0D0
59486           V(I,J)=0D0
59487   100   CONTINUE
59488   110 CONTINUE
59489  
59490 C...Check flavours.
59491       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59492       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59493       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59494       IF(MSTU(19).EQ.1) THEN
59495         MSTU(19)=0
59496       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
59497       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
59498      &  KQ1+KQ3.EQ.4)) THEN
59499       ELSE
59500         CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
59501       ENDIF
59502       K(IPA,2)=KF1
59503       K(IPA+1,2)=KF2
59504       K(IPA+2,2)=KF3
59505  
59506 C...Store partons/particles in K vectors for normal case.
59507       IF(IP.GE.0) THEN
59508         K(IPA,1)=1
59509         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
59510         K(IPA+1,1)=1
59511         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
59512         K(IPA+2,1)=1
59513  
59514 C...Store partons in K vectors for parton shower evolution.
59515       ELSE
59516         K(IPA,1)=3
59517         K(IPA+1,1)=3
59518         K(IPA+2,1)=3
59519         KCS=4
59520         IF(KQ1.EQ.-1) KCS=5
59521         K(IPA,KCS)=MSTU(5)*(IPA+1)
59522         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
59523         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59524         K(IPA+1,9-KCS)=MSTU(5)*IPA
59525         K(IPA+2,KCS)=MSTU(5)*IPA
59526         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59527       ENDIF
59528  
59529 C...Check kinematics.
59530       MKERR=0
59531       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
59532      &0.5D0*X3*PECM.LE.PM3) MKERR=1
59533       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59534       PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
59535       PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
59536       CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
59537       CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
59538       IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
59539       CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
59540       IF(MKERR.NE.0) CALL PYERRM(13,
59541      &'(PY3ENT:) unphysical kinematical variable setup')
59542  
59543 C...Store partons/particles in P vectors.
59544       P(IPA,3)=PA1
59545       P(IPA,4)=SQRT(PA1**2+PM1**2)
59546       P(IPA,5)=PM1
59547       P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
59548       P(IPA+2,3)=PA3*CTHE3
59549       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
59550       P(IPA+2,5)=PM3
59551       P(IPA+1,1)=-P(IPA+2,1)
59552       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
59553       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
59554       P(IPA+1,5)=PM2
59555  
59556 C...Set N. Optionally fragment/decay.
59557       N=IPA+2
59558       IF(IP.EQ.0) CALL PYEXEC
59559  
59560       RETURN
59561       END
59562  
59563 C*********************************************************************
59564  
59565 C...PY4ENT
59566 C...Stores four partons or particles in their CM frame, with
59567 C...the first along the +z axis, the last in the xz plane with x > 0
59568 C...and the second having y < 0 and y > 0 with equal probability.
59569  
59570       SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
59571  
59572 C...Double precision and integer declarations.
59573       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59574       IMPLICIT INTEGER(I-N)
59575       INTEGER PYK,PYCHGE,PYCOMP
59576 C...Commonblocks.
59577       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59578       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59579       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59580       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59581  
59582 C...Standard checks.
59583       MSTU(28)=0
59584       IF(MSTU(12).NE.12345) CALL PYLIST(0)
59585       IPA=MAX(1,IABS(IP))
59586       IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
59587      &'(PY4ENT:) writing outside PYJETS momory')
59588       KC1=PYCOMP(KF1)
59589       KC2=PYCOMP(KF2)
59590       KC3=PYCOMP(KF3)
59591       KC4=PYCOMP(KF4)
59592       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
59593      &'(PY4ENT:) unknown flavour code')
59594  
59595 C...Find masses. Reset K, P and V vectors.
59596       PM1=0D0
59597       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59598       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59599       PM2=0D0
59600       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59601       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59602       PM3=0D0
59603       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59604       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59605       PM4=0D0
59606       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
59607       IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
59608       DO 110 I=IPA,IPA+3
59609         DO 100 J=1,5
59610           K(I,J)=0
59611           P(I,J)=0D0
59612           V(I,J)=0D0
59613   100   CONTINUE
59614   110 CONTINUE
59615  
59616 C...Check flavours.
59617       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59618       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59619       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59620       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
59621       IF(MSTU(19).EQ.1) THEN
59622         MSTU(19)=0
59623       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
59624       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
59625      &  KQ1+KQ4.EQ.4)) THEN
59626       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
59627      &  THEN
59628       ELSE
59629         CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
59630       ENDIF
59631       K(IPA,2)=KF1
59632       K(IPA+1,2)=KF2
59633       K(IPA+2,2)=KF3
59634       K(IPA+3,2)=KF4
59635  
59636 C...Store partons/particles in K vectors for normal case.
59637       IF(IP.GE.0) THEN
59638         K(IPA,1)=1
59639         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
59640         K(IPA+1,1)=1
59641         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
59642      &  K(IPA+1,1)=2
59643         K(IPA+2,1)=1
59644         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
59645         K(IPA+3,1)=1
59646  
59647 C...Store partons for parton shower evolution from q-g-g-qbar or
59648 C...g-g-g-g event.
59649       ELSEIF(KQ1+KQ2.NE.0) THEN
59650         K(IPA,1)=3
59651         K(IPA+1,1)=3
59652         K(IPA+2,1)=3
59653         K(IPA+3,1)=3
59654         KCS=4
59655         IF(KQ1.EQ.-1) KCS=5
59656         K(IPA,KCS)=MSTU(5)*(IPA+1)
59657         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
59658         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59659         K(IPA+1,9-KCS)=MSTU(5)*IPA
59660         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
59661         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59662         K(IPA+3,KCS)=MSTU(5)*IPA
59663         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
59664  
59665 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
59666       ELSE
59667         K(IPA,1)=3
59668         K(IPA+1,1)=3
59669         K(IPA+2,1)=3
59670         K(IPA+3,1)=3
59671         K(IPA,4)=MSTU(5)*(IPA+1)
59672         K(IPA,5)=K(IPA,4)
59673         K(IPA+1,4)=MSTU(5)*IPA
59674         K(IPA+1,5)=K(IPA+1,4)
59675         K(IPA+2,4)=MSTU(5)*(IPA+3)
59676         K(IPA+2,5)=K(IPA+2,4)
59677         K(IPA+3,4)=MSTU(5)*(IPA+2)
59678         K(IPA+3,5)=K(IPA+3,4)
59679       ENDIF
59680  
59681 C...Check kinematics.
59682       MKERR=0
59683       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
59684      &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
59685      &MKERR=1
59686       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59687       PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
59688       PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
59689       X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
59690       CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
59691       IF(ABS(CTHE4).GE.1.002D0) MKERR=1
59692       CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
59693       STHE4=SQRT(1D0-CTHE4**2)
59694       CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
59695       IF(ABS(CTHE2).GE.1.002D0) MKERR=1
59696       CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
59697       STHE2=SQRT(1D0-CTHE2**2)
59698       CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
59699      &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
59700       IF(ABS(CPHI2).GE.1.05D0) MKERR=1
59701       CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
59702       IF(MKERR.EQ.1) CALL PYERRM(13,
59703      &'(PY4ENT:) unphysical kinematical variable setup')
59704  
59705 C...Store partons/particles in P vectors.
59706       P(IPA,3)=PA1
59707       P(IPA,4)=SQRT(PA1**2+PM1**2)
59708       P(IPA,5)=PM1
59709       P(IPA+3,1)=PA4*STHE4
59710       P(IPA+3,3)=PA4*CTHE4
59711       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
59712       P(IPA+3,5)=PM4
59713       P(IPA+1,1)=PA2*STHE2*CPHI2
59714       P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
59715       P(IPA+1,3)=PA2*CTHE2
59716       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
59717       P(IPA+1,5)=PM2
59718       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
59719       P(IPA+2,2)=-P(IPA+1,2)
59720       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
59721       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
59722       P(IPA+2,5)=PM3
59723  
59724 C...Set N. Optionally fragment/decay.
59725       N=IPA+3
59726       IF(IP.EQ.0) CALL PYEXEC
59727  
59728       RETURN
59729       END
59730  
59731 C*********************************************************************
59732  
59733 C...PY2FRM
59734 C...An interface from a two-fermion generator to include
59735 C...parton showers and hadronization.
59736  
59737       SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
59738  
59739 C...Double precision and integer declarations.
59740       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59741       IMPLICIT INTEGER(I-N)
59742       INTEGER PYK,PYCHGE,PYCOMP
59743 C...Commonblocks.
59744       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59745       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59746       SAVE /PYJETS/,/PYDAT1/
59747 C...Local arrays.
59748       DIMENSION IJOIN(2),INTAU(2)
59749  
59750 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59751       IF(ICOM.EQ.0) THEN
59752         MSTU(28)=0
59753         CALL PYHEPC(2)
59754       ENDIF
59755  
59756 C...Loop through entries and pick up all final fermions/antifermions.
59757       I1=0
59758       I2=0
59759       DO 100 I=1,N
59760       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59761       KFA=IABS(K(I,2))
59762       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59763         IF(K(I,2).GT.0) THEN
59764           IF(I1.EQ.0) THEN
59765             I1=I
59766           ELSE
59767             CALL PYERRM(16,'(PY2FRM:) more than one fermion')
59768           ENDIF
59769         ELSE
59770           IF(I2.EQ.0) THEN
59771             I2=I
59772           ELSE
59773             CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
59774           ENDIF
59775         ENDIF
59776       ENDIF
59777   100 CONTINUE
59778  
59779 C...Check that event is arranged according to conventions.
59780       IF(I1.EQ.0.OR.I2.EQ.0) THEN
59781         CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
59782       ENDIF
59783       IF(I2.LT.I1) THEN
59784         CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
59785       ENDIF
59786  
59787 C...Check whether fermion pair is quarks or leptons.
59788       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59789         IQL12=1
59790       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59791         IQL12=2
59792       ELSE
59793         CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
59794       ENDIF
59795  
59796 C...Decide whether to allow or not photon radiation in showers.
59797       MSTJ(41)=2
59798       IF(IRAD.EQ.0) MSTJ(41)=1
59799  
59800 C...Do colour joining and parton showers.
59801       IP1=I1
59802       IP2=I2
59803       IF(IQL12.EQ.1) THEN
59804         IJOIN(1)=IP1
59805         IJOIN(2)=IP2
59806         CALL PYJOIN(2,IJOIN)
59807       ENDIF
59808       IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59809         PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59810      &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59811         CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59812       ENDIF
59813  
59814 C...Do fragmentation and decays. Possibly except tau decay.
59815       IF(ITAU.EQ.0) THEN
59816         NTAU=0
59817         DO 110 I=1,N
59818         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59819           NTAU=NTAU+1
59820           INTAU(NTAU)=I
59821           K(I,1)=11
59822         ENDIF
59823   110   CONTINUE
59824       ENDIF
59825       CALL PYEXEC
59826       IF(ITAU.EQ.0) THEN
59827         DO 120 I=1,NTAU
59828         K(INTAU(I),1)=1
59829   120   CONTINUE
59830       ENDIF
59831  
59832 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59833       IF(ICOM.EQ.0) THEN
59834         MSTU(28)=0
59835         CALL PYHEPC(1)
59836       ENDIF
59837  
59838       END
59839  
59840 C*********************************************************************
59841  
59842 C...PY4FRM
59843 C...An interface from a four-fermion generator to include
59844 C...parton showers and hadronization.
59845  
59846       SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59847  
59848 C...Double precision and integer declarations.
59849       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59850       IMPLICIT INTEGER(I-N)
59851       INTEGER PYK,PYCHGE,PYCOMP
59852 C...Commonblocks.
59853       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59854       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59855       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59856       COMMON/PYINT1/MINT(400),VINT(400)
59857       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59858 C...Local arrays.
59859       DIMENSION IJOIN(2),INTAU(4)
59860  
59861 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59862       IF(ICOM.EQ.0) THEN
59863         MSTU(28)=0
59864         CALL PYHEPC(2)
59865       ENDIF
59866  
59867 C...Loop through entries and pick up all final fermions/antifermions.
59868       I1=0
59869       I2=0
59870       I3=0
59871       I4=0
59872       DO 100 I=1,N
59873       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59874       KFA=IABS(K(I,2))
59875       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59876         IF(K(I,2).GT.0) THEN
59877           IF(I1.EQ.0) THEN
59878             I1=I
59879           ELSEIF(I3.EQ.0) THEN
59880             I3=I
59881           ELSE
59882             CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59883           ENDIF
59884         ELSE
59885           IF(I2.EQ.0) THEN
59886             I2=I
59887           ELSEIF(I4.EQ.0) THEN
59888             I4=I
59889           ELSE
59890             CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59891           ENDIF
59892         ENDIF
59893       ENDIF
59894   100 CONTINUE
59895  
59896 C...Check that event is arranged according to conventions.
59897       IF(I3.EQ.0.OR.I4.EQ.0) THEN
59898         CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59899       ENDIF
59900       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59901         CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59902       ENDIF
59903  
59904 C...Check which fermion pairs are quarks and which leptons.
59905       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59906         IQL12=1
59907       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59908         IQL12=2
59909       ELSE
59910         CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59911       ENDIF
59912       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59913         IQL34=1
59914       ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59915         IQL34=2
59916       ELSE
59917         CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59918       ENDIF
59919  
59920 C...Decide whether to allow or not photon radiation in showers.
59921       MSTJ(41)=2
59922       IF(IRAD.EQ.0) MSTJ(41)=1
59923  
59924 C...Decide on dipole pairing.
59925       IP1=I1
59926       IP2=I2
59927       IP3=I3
59928       IP4=I4
59929       IF(IQL12.EQ.IQL34) THEN
59930         R1SQ=A1SQ
59931         R2SQ=A2SQ
59932         DELTA=ATOTSQ-A1SQ-A2SQ
59933         IF(ISTRAT.EQ.1) THEN
59934           IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59935           IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59936         ELSEIF(ISTRAT.EQ.2) THEN
59937           IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59938           IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59939         ENDIF
59940         IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59941           IP2=I4
59942           IP4=I2
59943         ENDIF
59944       ENDIF
59945  
59946 C...If colour reconnection then bookkeep W+W- or Z0Z0
59947 C...and copy q qbar q qbar consecutively.
59948       IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59949         K(N+1,1)=11
59950         K(N+1,3)=IP1
59951         K(N+1,4)=N+3
59952         K(N+1,5)=N+4
59953         K(N+2,1)=11
59954         K(N+2,3)=IP3
59955         K(N+2,4)=N+5
59956         K(N+2,5)=N+6
59957         IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59958           K(N+1,2)=23
59959           K(N+2,2)=23
59960           MINT(1)=22
59961         ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59962           K(N+1,2)=24
59963           K(N+2,2)=-24
59964           MINT(1)=25
59965         ELSE
59966           K(N+1,2)=-24
59967           K(N+2,2)=24
59968           MINT(1)=25
59969         ENDIF
59970         DO 110 J=1,5
59971           K(N+3,J)=K(IP1,J)
59972           K(N+4,J)=K(IP2,J)
59973           K(N+5,J)=K(IP3,J)
59974           K(N+6,J)=K(IP4,J)
59975           P(N+1,J)=P(IP1,J)+P(IP2,J)
59976           P(N+2,J)=P(IP3,J)+P(IP4,J)
59977           P(N+3,J)=P(IP1,J)
59978           P(N+4,J)=P(IP2,J)
59979           P(N+5,J)=P(IP3,J)
59980           P(N+6,J)=P(IP4,J)
59981           V(N+1,J)=V(IP1,J)
59982           V(N+2,J)=V(IP3,J)
59983           V(N+3,J)=V(IP1,J)
59984           V(N+4,J)=V(IP2,J)
59985           V(N+5,J)=V(IP3,J)
59986           V(N+6,J)=V(IP4,J)
59987   110   CONTINUE
59988         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59989      &  P(N+1,3)**2))
59990         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59991      &  P(N+2,3)**2))
59992         K(N+3,3)=N+1
59993         K(N+4,3)=N+1
59994         K(N+5,3)=N+2
59995         K(N+6,3)=N+2
59996 C...Remove original q qbar q qbar and update counters.
59997         K(IP1,1)=K(IP1,1)+10
59998         K(IP2,1)=K(IP2,1)+10
59999         K(IP3,1)=K(IP3,1)+10
60000         K(IP4,1)=K(IP4,1)+10
60001         IW1=N+1
60002         IW2=N+2
60003         NSD1=N+2
60004         IP1=N+3
60005         IP2=N+4
60006         IP3=N+5
60007         IP4=N+6
60008         N=N+6
60009       ENDIF
60010  
60011 C...Do colour joinings and parton showers.
60012       IF(IQL12.EQ.1) THEN
60013         IJOIN(1)=IP1
60014         IJOIN(2)=IP2
60015         CALL PYJOIN(2,IJOIN)
60016       ENDIF
60017       IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
60018         PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
60019      &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
60020         CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
60021       ENDIF
60022       NAFT1=N
60023       IF(IQL34.EQ.1) THEN
60024         IJOIN(1)=IP3
60025         IJOIN(2)=IP4
60026         CALL PYJOIN(2,IJOIN)
60027       ENDIF
60028       IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60029         PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60030      &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60031         CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60032       ENDIF
60033  
60034 C...Optionally do colour reconnection.
60035       MINT(32)=0
60036       MSTI(32)=0
60037       IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
60038         CALL PYRECO(IW1,IW2,NSD1,NAFT1)
60039         MSTI(32)=MINT(32)
60040       ENDIF
60041  
60042 C...Do fragmentation and decays. Possibly except tau decay.
60043       IF(ITAU.EQ.0) THEN
60044         NTAU=0
60045         DO 120 I=1,N
60046         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60047           NTAU=NTAU+1
60048           INTAU(NTAU)=I
60049           K(I,1)=11
60050         ENDIF
60051   120   CONTINUE
60052       ENDIF
60053       CALL PYEXEC
60054       IF(ITAU.EQ.0) THEN
60055         DO 130 I=1,NTAU
60056         K(INTAU(I),1)=1
60057   130   CONTINUE
60058       ENDIF
60059  
60060 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60061       IF(ICOM.EQ.0) THEN
60062         MSTU(28)=0
60063         CALL PYHEPC(1)
60064       ENDIF
60065  
60066       END
60067  
60068 C*********************************************************************
60069  
60070 C...PY6FRM
60071 C...An interface from a six-fermion generator to include
60072 C...parton showers and hadronization.
60073  
60074       SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
60075  
60076 C...Double precision and integer declarations.
60077       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60078       IMPLICIT INTEGER(I-N)
60079       INTEGER PYK,PYCHGE,PYCOMP
60080 C...Commonblocks.
60081       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60082       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60083       SAVE /PYJETS/,/PYDAT1/
60084 C...Local arrays.
60085       DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
60086  
60087 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60088       IF(ICOM.EQ.0) THEN
60089         MSTU(28)=0
60090         CALL PYHEPC(2)
60091       ENDIF
60092  
60093 C...Loop through entries and pick up all final fermions/antifermions.
60094       I1=0
60095       I2=0
60096       I3=0
60097       I4=0
60098       I5=0
60099       I6=0
60100       DO 100 I=1,N
60101       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60102       KFA=IABS(K(I,2))
60103       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
60104         IF(K(I,2).GT.0) THEN
60105           IF(I1.EQ.0) THEN
60106             I1=I
60107           ELSEIF(I3.EQ.0) THEN
60108             I3=I
60109           ELSEIF(I5.EQ.0) THEN
60110             I5=I
60111           ELSE
60112             CALL PYERRM(16,'(PY6FRM:) more than three fermions')
60113           ENDIF
60114         ELSE
60115           IF(I2.EQ.0) THEN
60116             I2=I
60117           ELSEIF(I4.EQ.0) THEN
60118             I4=I
60119           ELSEIF(I6.EQ.0) THEN
60120             I6=I
60121           ELSE
60122             CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
60123           ENDIF
60124         ENDIF
60125       ENDIF
60126   100 CONTINUE
60127  
60128 C...Check that event is arranged according to conventions.
60129       IF(I5.EQ.0.OR.I6.EQ.0) THEN
60130         CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
60131       ENDIF
60132       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
60133         CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
60134       ENDIF
60135  
60136 C...Check which fermion pairs are quarks and which leptons.
60137       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
60138         IQL12=1
60139       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
60140         IQL12=2
60141       ELSE
60142         CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
60143       ENDIF
60144       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60145         IQL34=1
60146       ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
60147         IQL34=2
60148       ELSE
60149         CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
60150       ENDIF
60151       IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
60152         IQL56=1
60153       ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
60154         IQL56=2
60155       ELSE
60156         CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
60157       ENDIF
60158  
60159 C...Decide whether to allow or not photon radiation in showers.
60160       MSTJ(41)=2
60161       IF(IRAD.EQ.0) MSTJ(41)=1
60162  
60163 C...Allow dipole pairings only among leptons and quarks separately.
60164       P12D=P12
60165       P13D=0D0
60166       IF(IQL34.EQ.IQL56) P13D=P13
60167       P21D=0D0
60168       IF(IQL12.EQ.IQL34) P21D=P21
60169       P23D=0D0
60170       IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
60171       P31D=0D0
60172       IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
60173       P32D=0D0
60174       IF(IQL12.EQ.IQL56) P32D=P32
60175  
60176 C...Decide whether t+tbar.
60177       ITOP=0
60178       IF(PYR(0).LT.PTOP) THEN
60179         ITOP=1
60180  
60181 C...If t+tbar: reconstruct t's.
60182         IT=N+1
60183         ITB=N+2
60184         DO 110 J=1,5
60185           K(IT,J)=0
60186           K(ITB,J)=0
60187           P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
60188           P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
60189           V(IT,J)=0D0
60190           V(ITB,J)=0D0
60191   110   CONTINUE
60192         K(IT,1)=1
60193         K(ITB,1)=1
60194         K(IT,2)=6
60195         K(ITB,2)=-6
60196         P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
60197      &  P(IT,3)**2))
60198         P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
60199      &  P(ITB,3)**2))
60200         N=N+2
60201  
60202 C...If t+tbar: colour join t's and let them shower.
60203         IJOIN(1)=IT
60204         IJOIN(2)=ITB
60205         CALL PYJOIN(2,IJOIN)
60206         PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
60207      &  (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
60208         CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
60209  
60210 C...If t+tbar: pick up the t's after shower.
60211         ITNEW=IT
60212         ITBNEW=ITB
60213         DO 120 I=ITB+1,N
60214           IF(K(I,2).EQ.6) ITNEW=I
60215           IF(K(I,2).EQ.-6) ITBNEW=I
60216   120   CONTINUE
60217  
60218 C...If t+tbar: loop over two top systems.
60219         DO 200 IT1=1,2
60220           IF(IT1.EQ.1) THEN
60221             ITO=IT
60222             ITN=ITNEW
60223             IBO=I1
60224             IW1=I3
60225             IW2=I4
60226           ELSE
60227             ITO=ITB
60228             ITN=ITBNEW
60229             IBO=I2
60230             IW1=I5
60231             IW2=I6
60232           ENDIF
60233           IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
60234      &    '(PY6FRM:) not b in t decay')
60235  
60236 C...If t+tbar: find boost from original to new top frame.
60237           DO 130 J=1,3
60238             BETAO(J)=P(ITO,J)/P(ITO,4)
60239             BETAN(J)=P(ITN,J)/P(ITN,4)
60240   130     CONTINUE
60241  
60242 C...If t+tbar: boost copy of b by t shower and connect it in colour.
60243           N=N+1
60244           IB=N
60245           K(IB,1)=3
60246           K(IB,2)=K(IBO,2)
60247           K(IB,3)=ITN
60248           DO 140 J=1,5
60249             P(IB,J)=P(IBO,J)
60250             V(IB,J)=0D0
60251   140     CONTINUE
60252           CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60253           CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60254           K(IB,4)=MSTU(5)*ITN
60255           K(IB,5)=MSTU(5)*ITN
60256           K(ITN,4)=K(ITN,4)+IB
60257           K(ITN,5)=K(ITN,5)+IB
60258           K(ITN,1)=K(ITN,1)+10
60259           K(IBO,1)=K(IBO,1)+10
60260  
60261 C...If t+tbar: construct W recoiling against b.
60262           N=N+1
60263           IW=N
60264           DO 150 J=1,5
60265             K(IW,J)=0
60266             V(IW,J)=0D0
60267   150     CONTINUE
60268           K(IW,1)=1
60269           KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
60270           IF(IABS(KCHW).EQ.3) THEN
60271             K(IW,2)=ISIGN(24,KCHW)
60272           ELSE
60273             CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
60274           ENDIF
60275           K(IW,3)=IW1
60276  
60277 C...If t+tbar: construct W momentum, including boost by t shower.
60278           DO 160 J=1,4
60279             P(IW,J)=P(IW1,J)+P(IW2,J)
60280   160     CONTINUE
60281           P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
60282      &    P(IW,3)**2))
60283           CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60284           CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60285  
60286 C...If t+tbar: boost b and W to top rest frame.
60287           DO 170 J=1,3
60288             BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
60289   170     CONTINUE
60290           CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60291           CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60292  
60293 C...If t+tbar: let b shower and pick up modified W.
60294           PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
60295      &    (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
60296           CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
60297           DO 180 I=IW,N
60298             IF(IABS(K(I,2)).EQ.24) IWM=I
60299   180     CONTINUE
60300  
60301 C...If t+tbar: take copy of W decay products.
60302           DO 190 J=1,5
60303             K(N+1,J)=K(IW1,J)
60304             P(N+1,J)=P(IW1,J)
60305             V(N+1,J)=V(IW1,J)
60306             K(N+2,J)=K(IW2,J)
60307             P(N+2,J)=P(IW2,J)
60308             V(N+2,J)=V(IW2,J)
60309   190     CONTINUE
60310           K(IW1,1)=K(IW1,1)+10
60311           K(IW2,1)=K(IW2,1)+10
60312           K(IWM,1)=K(IWM,1)+10
60313           K(IWM,4)=N+1
60314           K(IWM,5)=N+2
60315           K(N+1,3)=IWM
60316           K(N+2,3)=IWM
60317           IF(IT1.EQ.1) THEN
60318             I3=N+1
60319             I4=N+2
60320           ELSE
60321             I5=N+1
60322             I6=N+2
60323           ENDIF
60324           N=N+2
60325  
60326 C...If t+tbar: boost W decay products, first by effects of t shower,
60327 C...then by those of b shower. b and its shower simple boost back.
60328           CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60329           CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60330           CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60331           CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
60332      &    -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
60333           CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
60334      &    P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
60335           CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
60336           CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
60337   200   CONTINUE
60338       ENDIF
60339  
60340 C...Decide on dipole pairing.
60341       IP1=I1
60342       IP3=I3
60343       IP5=I5
60344       PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
60345       IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
60346         IP2=I2
60347         IP4=I4
60348         IP6=I6
60349       ELSEIF(PRN.LT.P12D+P13D) THEN
60350         IP2=I2
60351         IP4=I6
60352         IP6=I4
60353       ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
60354         IP2=I4
60355         IP4=I2
60356         IP6=I6
60357       ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
60358         IP2=I4
60359         IP4=I6
60360         IP6=I2
60361       ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
60362         IP2=I6
60363         IP4=I2
60364         IP6=I4
60365       ELSE
60366         IP2=I6
60367         IP4=I4
60368         IP6=I2
60369       ENDIF
60370  
60371 C...Do colour joinings and parton showers
60372 C...(except ones already made for t+tbar).
60373       IF(ITOP.EQ.0) THEN
60374         IF(IQL12.EQ.1) THEN
60375           IJOIN(1)=IP1
60376           IJOIN(2)=IP2
60377           CALL PYJOIN(2,IJOIN)
60378         ENDIF
60379         IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
60380           PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
60381      &    (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
60382           CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
60383         ENDIF
60384       ENDIF
60385       IF(IQL34.EQ.1) THEN
60386         IJOIN(1)=IP3
60387         IJOIN(2)=IP4
60388         CALL PYJOIN(2,IJOIN)
60389       ENDIF
60390       IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60391         PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60392      &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60393         CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60394       ENDIF
60395       IF(IQL56.EQ.1) THEN
60396         IJOIN(1)=IP5
60397         IJOIN(2)=IP6
60398         CALL PYJOIN(2,IJOIN)
60399       ENDIF
60400       IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
60401         PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
60402      &  (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
60403         CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
60404       ENDIF
60405  
60406 C...Do fragmentation and decays. Possibly except tau decay.
60407       IF(ITAU.EQ.0) THEN
60408         NTAU=0
60409         DO 210 I=1,N
60410         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60411           NTAU=NTAU+1
60412           INTAU(NTAU)=I
60413           K(I,1)=11
60414         ENDIF
60415   210   CONTINUE
60416       ENDIF
60417       CALL PYEXEC
60418       IF(ITAU.EQ.0) THEN
60419         DO 220 I=1,NTAU
60420         K(INTAU(I),1)=1
60421   220   CONTINUE
60422       ENDIF
60423  
60424 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60425       IF(ICOM.EQ.0) THEN
60426         MSTU(28)=0
60427         CALL PYHEPC(1)
60428       ENDIF
60429  
60430       END
60431  
60432 C*********************************************************************
60433  
60434 C...PY4JET
60435 C...An interface from a four-parton generator to include
60436 C...parton showers and hadronization.
60437  
60438       SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
60439  
60440 C...Double precision and integer declarations.
60441       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60442       IMPLICIT INTEGER(I-N)
60443       INTEGER PYK,PYCHGE,PYCOMP
60444 C...Commonblocks.
60445       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60446       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60447       SAVE /PYJETS/,/PYDAT1/
60448 C...Local arrays.
60449       DIMENSION IJOIN(2),PTOT(4),BETA(3)
60450  
60451 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60452       IF(ICOM.EQ.0) THEN
60453         MSTU(28)=0
60454         CALL PYHEPC(2)
60455       ENDIF
60456  
60457 C...Loop through entries and pick up all final partons.
60458       I1=0
60459       I2=0
60460       I3=0
60461       I4=0
60462       DO 100 I=1,N
60463       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60464       KFA=IABS(K(I,2))
60465       IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
60466         IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
60467           IF(I1.EQ.0) THEN
60468             I1=I
60469           ELSEIF(I3.EQ.0) THEN
60470             I3=I
60471           ELSE
60472             CALL PYERRM(16,'(PY4JET:) more than two quarks')
60473           ENDIF
60474         ELSEIF(K(I,2).LT.0) THEN
60475           IF(I2.EQ.0) THEN
60476             I2=I
60477           ELSEIF(I4.EQ.0) THEN
60478             I4=I
60479           ELSE
60480             CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
60481           ENDIF
60482         ELSE
60483           IF(I3.EQ.0) THEN
60484             I3=I
60485           ELSEIF(I4.EQ.0) THEN
60486             I4=I
60487           ELSE
60488             CALL PYERRM(16,'(PY4JET:) more than two gluons')
60489           ENDIF
60490         ENDIF
60491       ENDIF
60492   100 CONTINUE
60493  
60494 C...Check that event is arranged according to conventions.
60495       IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
60496         CALL PYERRM(16,'(PY4JET:) event contains too few partons')
60497       ENDIF
60498       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
60499         CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
60500       ENDIF
60501  
60502 C...Check whether second pair are quarks or gluons.
60503       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60504         IQG34=1
60505       ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
60506         IQG34=2
60507       ELSE
60508         CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
60509       ENDIF
60510  
60511 C...Boost partons to their cm frame.
60512       DO 110 J=1,4
60513         PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
60514   110 CONTINUE
60515       ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
60516       DO 120 J=1,3
60517         BETA(J)=PTOT(J)/PTOT(4)
60518   120 CONTINUE
60519       CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60520       CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60521       CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60522       CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60523       NSAV=N
60524  
60525 C...Decide and set up shower history for q qbar q' qbar' events.
60526       IF(IQG34.EQ.1) THEN
60527         W1=PY4JTW(0,I1,I3,I4)
60528         W2=PY4JTW(0,I2,I3,I4)
60529         IF(W1.GT.PYR(0)*(W1+W2)) THEN
60530           CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60531         ELSE
60532           CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60533         ENDIF
60534  
60535 C...Decide and set up shower history for q qbar g g events.
60536       ELSE
60537         W1=PY4JTW(I1,I3,I2,I4)
60538         W2=PY4JTW(I1,I4,I2,I3)
60539         W3=PY4JTW(0,I3,I1,I4)
60540         W4=PY4JTW(0,I4,I1,I3)
60541         W5=PY4JTW(0,I3,I2,I4)
60542         W6=PY4JTW(0,I4,I2,I3)
60543         W7=PY4JTW(0,I1,I3,I4)
60544         W8=PY4JTW(0,I2,I3,I4)
60545         WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
60546         IF(W1.GT.WR) THEN
60547           CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
60548         ELSEIF(W1+W2.GT.WR) THEN
60549           CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
60550         ELSEIF(W1+W2+W3.GT.WR) THEN
60551           CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
60552         ELSEIF(W1+W2+W3+W4.GT.WR) THEN
60553           CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
60554         ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
60555           CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
60556         ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
60557           CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
60558         ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
60559           CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60560         ELSE
60561           CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60562         ENDIF
60563       ENDIF
60564  
60565 C...Boost back original partons and mark them as deleted.
60566       CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
60567       CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
60568       CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
60569       CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
60570       K(I1,1)=K(I1,1)+10
60571       K(I2,1)=K(I2,1)+10
60572       K(I3,1)=K(I3,1)+10
60573       K(I4,1)=K(I4,1)+10
60574  
60575 C...Rotate shower initiating partons to be along z axis.
60576       PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
60577       CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
60578       THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
60579       CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
60580  
60581 C...Set up copy of shower initiating partons as on mass shell.
60582       DO 140 I=N+1,N+2
60583         DO 130 J=1,5
60584           K(I,J)=0
60585           P(I,J)=0D0
60586           V(I,J)=V(I1,J)
60587   130   CONTINUE
60588         K(I,1)=1
60589         K(I,2)=K(I-6,2)
60590   140 CONTINUE
60591       IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
60592         K(N+1,3)=I1
60593         P(N+1,5)=P(I1,5)
60594         K(N+2,3)=I2
60595         P(N+2,5)=P(I2,5)
60596       ELSE
60597         K(N+1,3)=I2
60598         P(N+1,5)=P(I2,5)
60599         K(N+2,3)=I1
60600         P(N+2,5)=P(I1,5)
60601       ENDIF
60602       PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
60603      &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
60604       P(N+1,3)=PABS
60605       P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
60606       P(N+2,3)=-PABS
60607       P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
60608       N=N+2
60609  
60610 C...Decide whether to allow or not photon radiation in showers.
60611 C...Connect up colours.
60612       MSTJ(41)=2
60613       IF(IRAD.EQ.0) MSTJ(41)=1
60614       IJOIN(1)=N-1
60615       IJOIN(2)=N
60616       CALL PYJOIN(2,IJOIN)
60617  
60618 C...Decide on maximum virtuality and do parton shower.
60619       IF(PMAX.LT.PARJ(82)) THEN
60620         PQMAX=QMAX
60621       ELSE
60622         PQMAX=PMAX
60623       ENDIF
60624       CALL PYSHOW(NSAV+1,-100,PQMAX)
60625  
60626 C...Rotate and boost back system.
60627       CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
60628  
60629 C...Do fragmentation and decays.
60630       CALL PYEXEC
60631  
60632 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60633       IF(ICOM.EQ.0) THEN
60634         MSTU(28)=0
60635         CALL PYHEPC(1)
60636       ENDIF
60637  
60638       RETURN
60639       END
60640  
60641 C*********************************************************************
60642  
60643 C...PY4JTW
60644 C...Auxiliary to PY4JET, to evaluate weight of configuration.
60645  
60646       FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
60647  
60648 C...Double precision and integer declarations.
60649       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60650       IMPLICIT INTEGER(I-N)
60651       INTEGER PYK,PYCHGE,PYCOMP
60652 C...Commonblocks.
60653       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60654       SAVE /PYJETS/
60655  
60656 C...First case: when both original partons radiate.
60657 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
60658       IF(IA1.NE.0) THEN
60659         DO 100 J=1,4
60660           P(N+1,J)=P(IA1,J)+P(IA2,J)
60661           P(N+2,J)=P(IA3,J)+P(IA4,J)
60662   100   CONTINUE
60663         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60664      &  P(N+1,3)**2))
60665         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60666      &  P(N+2,3)**2))
60667         Z1=P(IA1,4)/P(N+1,4)
60668         WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
60669         Z2=P(IA3,4)/P(N+2,4)
60670         WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
60671  
60672 C...Second case: when one original parton radiates to three.
60673 C...IA1  = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
60674       ELSE
60675         DO 110 J=1,4
60676           P(N+2,J)=P(IA3,J)+P(IA4,J)
60677           P(N+1,J)=P(N+2,J)+P(IA2,J)
60678   110   CONTINUE
60679         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60680      &  P(N+1,3)**2))
60681         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60682      &  P(N+2,3)**2))
60683         IF(K(IA2,2).EQ.21) THEN
60684           Z1=P(N+2,4)/P(N+1,4)
60685           WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60686      &    P(IA3,5)**2)
60687         ELSE
60688           Z1=P(IA2,4)/P(N+1,4)
60689           WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60690      &    P(IA2,5)**2)
60691         ENDIF
60692         Z2=P(IA3,4)/P(N+2,4)
60693         IF(K(IA2,2).EQ.21) THEN
60694           WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
60695      &    P(IA3,5)**2)
60696         ELSEIF(K(IA3,2).EQ.21) THEN
60697           WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
60698         ELSE
60699           WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
60700         ENDIF
60701       ENDIF
60702  
60703 C...Total weight.
60704       PY4JTW=WT1*WT2
60705  
60706       RETURN
60707       END
60708  
60709 C*********************************************************************
60710  
60711 C...PY4JTS
60712 C...Auxiliary to PY4JET, to set up chosen configuration.
60713  
60714       SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
60715  
60716 C...Double precision and integer declarations.
60717       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60718       IMPLICIT INTEGER(I-N)
60719       INTEGER PYK,PYCHGE,PYCOMP
60720 C...Commonblocks.
60721       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60722       SAVE /PYJETS/
60723  
60724 C...Reset info.
60725       DO 110 I=N+1,N+6
60726         DO 100 J=1,5
60727           K(I,J)=0
60728           V(I,J)=V(IA2,J)
60729   100   CONTINUE
60730         K(I,1)=16
60731   110 CONTINUE
60732  
60733 C...First case: when both original partons radiate.
60734 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
60735       IF(IA1.NE.0) THEN
60736  
60737 C...Set up flavour and history pointers for new partons.
60738         K(N+1,2)=K(IA1,2)
60739         K(N+2,2)=K(IA3,2)
60740         K(N+3,2)=K(IA1,2)
60741         K(N+4,2)=K(IA2,2)
60742         K(N+5,2)=K(IA3,2)
60743         K(N+6,2)=K(IA4,2)
60744         K(N+1,3)=IA1
60745         K(N+1,4)=N+3
60746         K(N+1,5)=N+4
60747         K(N+2,3)=IA3
60748         K(N+2,4)=N+5
60749         K(N+2,5)=N+6
60750         K(N+3,3)=N+1
60751         K(N+4,3)=N+1
60752         K(N+5,3)=N+2
60753         K(N+6,3)=N+2
60754  
60755 C...Set up momenta for new partons.
60756         DO 120 J=1,5
60757           P(N+1,J)=P(IA1,J)+P(IA2,J)
60758           P(N+2,J)=P(IA3,J)+P(IA4,J)
60759           P(N+3,J)=P(IA1,J)
60760           P(N+4,J)=P(IA2,J)
60761           P(N+5,J)=P(IA3,J)
60762           P(N+6,J)=P(IA4,J)
60763   120   CONTINUE
60764         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60765      &  P(N+1,3)**2))
60766         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60767      &  P(N+2,3)**2))
60768         QMAX=MIN(P(N+1,5),P(N+2,5))
60769  
60770 C...Second case: q radiates twice.
60771 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
60772 C...IA5=N+2 does not radiate.
60773       ELSEIF(K(IA2,2).EQ.21) THEN
60774  
60775 C...Set up flavour and history pointers for new partons.
60776         K(N+1,2)=K(IA3,2)
60777         K(N+2,2)=K(IA5,2)
60778         K(N+3,2)=K(IA3,2)
60779         K(N+4,2)=K(IA2,2)
60780         K(N+5,2)=K(IA3,2)
60781         K(N+6,2)=K(IA4,2)
60782         K(N+1,3)=IA3
60783         K(N+1,4)=N+3
60784         K(N+1,5)=N+4
60785         K(N+2,3)=IA5
60786         K(N+3,3)=N+1
60787         K(N+3,4)=N+5
60788         K(N+3,5)=N+6
60789         K(N+4,3)=N+1
60790         K(N+5,3)=N+3
60791         K(N+6,3)=N+3
60792  
60793 C...Set up momenta for new partons.
60794         DO 130 J=1,5
60795           P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60796           P(N+2,J)=P(IA5,J)
60797           P(N+3,J)=P(IA3,J)+P(IA4,J)
60798           P(N+4,J)=P(IA2,J)
60799           P(N+5,J)=P(IA3,J)
60800           P(N+6,J)=P(IA4,J)
60801   130   CONTINUE
60802         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60803      &  P(N+1,3)**2))
60804         P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
60805      &  P(N+3,3)**2))
60806         QMAX=P(N+3,5)
60807  
60808 C...Third case: q radiates g, g branches.
60809 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
60810 C...IA5=N+2 does not radiate.
60811       ELSE
60812  
60813 C...Set up flavour and history pointers for new partons.
60814         K(N+1,2)=K(IA2,2)
60815         K(N+2,2)=K(IA5,2)
60816         K(N+3,2)=K(IA2,2)
60817         K(N+4,2)=21
60818         K(N+5,2)=K(IA3,2)
60819         K(N+6,2)=K(IA4,2)
60820         K(N+1,3)=IA2
60821         K(N+1,4)=N+3
60822         K(N+1,5)=N+4
60823         K(N+2,3)=IA5
60824         K(N+3,3)=N+1
60825         K(N+4,3)=N+1
60826         K(N+4,4)=N+5
60827         K(N+4,5)=N+6
60828         K(N+5,3)=N+4
60829         K(N+6,3)=N+4
60830  
60831 C...Set up momenta for new partons.
60832         DO 140 J=1,5
60833           P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60834           P(N+2,J)=P(IA5,J)
60835           P(N+3,J)=P(IA2,J)
60836           P(N+4,J)=P(IA3,J)+P(IA4,J)
60837           P(N+5,J)=P(IA3,J)
60838           P(N+6,J)=P(IA4,J)
60839   140   CONTINUE
60840         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60841      &  P(N+1,3)**2))
60842         P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60843      &  P(N+4,3)**2))
60844         QMAX=P(N+4,5)
60845  
60846       ENDIF
60847       N=N+6
60848  
60849       RETURN
60850       END
60851  
60852 C*********************************************************************
60853  
60854 C...PYJOIN
60855 C...Connects a sequence of partons with colour flow indices,
60856 C...as required for subsequent shower evolution (or other operations).
60857  
60858       SUBROUTINE PYJOIN(NJOIN,IJOIN)
60859  
60860 C...Double precision and integer declarations.
60861       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60862       IMPLICIT INTEGER(I-N)
60863       INTEGER PYK,PYCHGE,PYCOMP
60864 C...Commonblocks.
60865       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60866       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60867       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60868       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60869 C...Local array.
60870       DIMENSION IJOIN(*)
60871  
60872 C...Check that partons are of right types to be connected.
60873       IF(NJOIN.LT.2) GOTO 120
60874       KQSUM=0
60875       DO 100 IJN=1,NJOIN
60876         I=IJOIN(IJN)
60877         IF(I.LE.0.OR.I.GT.N) GOTO 120
60878         IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60879         KC=PYCOMP(K(I,2))
60880         IF(KC.EQ.0) GOTO 120
60881         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60882         IF(KQ.EQ.0) GOTO 120
60883         IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60884         IF(KQ.NE.2) KQSUM=KQSUM+KQ
60885         IF(IJN.EQ.1) KQS=KQ
60886   100 CONTINUE
60887       IF(KQSUM.NE.0) GOTO 120
60888  
60889 C...Connect the partons sequentially (closing for gluon loop).
60890       KCS=(9-KQS)/2
60891       IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60892       DO 110 IJN=1,NJOIN
60893         I=IJOIN(IJN)
60894         K(I,1)=3
60895         IF(IJN.NE.1) IP=IJOIN(IJN-1)
60896         IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60897         IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60898         IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60899         K(I,KCS)=MSTU(5)*IN
60900         K(I,9-KCS)=MSTU(5)*IP
60901         IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60902         IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60903   110 CONTINUE
60904  
60905 C...Error exit: no action taken.
60906       RETURN
60907   120 CALL PYERRM(12,
60908      &'(PYJOIN:) given entries can not be joined by one string')
60909  
60910       RETURN
60911       END
60912  
60913 C*********************************************************************
60914  
60915 C...PYGIVE
60916 C...Sets values of commonblock variables.
60917  
60918       SUBROUTINE PYGIVE(CHIN)
60919  
60920 C...Double precision and integer declarations.
60921       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60922       IMPLICIT INTEGER(I-N)
60923       INTEGER PYK,PYCHGE,PYCOMP
60924 C...Commonblocks.
60925       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60926       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60927       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60928       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60929       COMMON/PYDAT4/CHAF(500,2)
60930       CHARACTER CHAF*16
60931       COMMON/PYDATR/MRPY(6),RRPY(100)
60932       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60933       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60934       COMMON/PYINT1/MINT(400),VINT(400)
60935       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60936       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60937       COMMON/PYINT4/MWID(500),WIDS(500,5)
60938       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60939       COMMON/PYINT6/PROC(0:500)
60940       CHARACTER PROC*28
60941       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60942       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60943      &XPDIR(-6:6)
60944       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60945       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60946       COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60947       COMMON/PYPUED/IUED(0:99),RUED(0:99)
60948       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60949      &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60950      &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60951 C...Local arrays and character variables.
60952       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60953      &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60954      &CHINR*16,CHDIG*10
60955       DIMENSION MSVAR(56,8)
60956  
60957 C...For each variable to be translated give: name,
60958 C...integer/real/character, no. of indices, lower&upper index bounds.
60959       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60960      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60961      &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60962      &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60963      &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60964      &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60965      &'ITCM','RTCM','IUED','RUED'/
60966       DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0,  1,2,1,4000,1,5,2*0,
60967      &2,2,1,4000,1,5,2*0,  2,2,1,4000,1,5,2*0,  1,1,1,200,4*0,
60968      &2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
60969      &1,2,1,500,1,4,2*0,  2,2,1,500,1,4,2*0,  2,1,1,2000,4*0,
60970      &2,2,1,4,1,4,2*0,  1,2,1,500,1,3,2*0,  1,2,1,8000,1,2,2*0,
60971      &2,1,1,8000,4*0,  1,2,1,8000,1,5,2*0,  3,2,1,500,1,2,2*0,
60972      &1,1,1,6,4*0,  2,1,1,100,4*0,
60973      &1,7*0,  1,1,1,500,4*0,  1,2,1,2,-40,40,2*0,  2,1,1,200,4*0,
60974      &1,1,1,200,4*0,  2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
60975      &1,1,1,400,4*0,  2,1,1,400,4*0,  1,1,1,500,4*0,
60976      &1,2,1,500,1,2,2*0,  2,2,1,500,1,20,2*0,  1,3,1,40,1,4,1,2,
60977      &2,2,1,2,-40,40,2*0,  1,2,1,1000,1,3,2*0,  2,1,1,1000,4*0,
60978      &1,1,1,500,4*0,   2,2,1,500,1,5,2*0,   1,2,0,500,1,3,2*0,
60979      &2,2,0,500,1,3,2*0,   4,1,0,500,4*0,   2,3,0,6,0,6,0,5,
60980      &2,1,-6,6,4*0,     2,1,-6,6,4*0,    2,1,-6,6,4*0,
60981      &2,1,-6,6,4*0,  2,1,-6,6,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0,
60982      &2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3,
60983      &1,1,0,99,4*0,  2,1,0,99,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0/
60984       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60985      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60986  
60987 C...Length of character variable. Subdivide it into instructions.
60988       IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60989      &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60990       CHBIT=CHIN//' '
60991       LBIT=101
60992   100 LBIT=LBIT-1
60993       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60994       LTOT=0
60995       DO 110 LCOM=1,LBIT
60996         IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60997         LTOT=LTOT+1
60998         CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60999   110 CONTINUE
61000       LLOW=0
61001   120 LHIG=LLOW+1
61002   130 LHIG=LHIG+1
61003       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
61004       LBIT=LHIG-LLOW-1
61005       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
61006 
61007 C...Send off decay-mode on/off commands to PYONOF.
61008       IONOF=0
61009       DO 135 LDIG=1,10
61010         IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
61011   135 CONTINUE
61012       IF(IONOF.EQ.1) THEN
61013         CALL PYONOF(CHIN)
61014         RETURN
61015       ENDIF   
61016  
61017 C...Peel off any text following exclamation mark.
61018       LHIG2=LBIT
61019       DO 140 LLOW2=LHIG2,1,-1
61020         IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
61021   140 CONTINUE
61022       IF(LBIT.EQ.0) RETURN
61023  
61024 C...Identify commonblock variable.
61025       LNAM=1
61026   150 LNAM=LNAM+1
61027       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
61028      &LNAM.LE.6) GOTO 150
61029       CHNAM=CHBIT(1:LNAM-1)//' '
61030       DO 170 LCOM=1,LNAM-1
61031         DO 160 LALP=1,26
61032           IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
61033      &    CHALP(2)(LALP:LALP)
61034   160   CONTINUE
61035   170 CONTINUE
61036       IVAR=0
61037       DO 180 IV=1,56
61038         IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
61039   180 CONTINUE
61040       IF(IVAR.EQ.0) THEN
61041         CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
61042         LLOW=LHIG
61043         IF(LLOW.LT.LTOT) GOTO 120
61044         RETURN
61045       ENDIF
61046  
61047 C...Identify any indices.
61048       I1=0
61049       I2=0
61050       I3=0
61051       NINDX=0
61052       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
61053         LIND=LNAM
61054   190   LIND=LIND+1
61055         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
61056         CHIND=' '
61057         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
61058      &  .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
61059      &  IVAR.EQ.37)) THEN
61060           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
61061           READ(CHIND,'(I8)') KF
61062           I1=PYCOMP(KF)
61063         ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
61064      &    'c') THEN
61065           CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
61066      &    CHNAM)
61067           LLOW=LHIG
61068           IF(LLOW.LT.LTOT) GOTO 120
61069           RETURN
61070         ELSE
61071           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61072           READ(CHIND,'(I8)') I1
61073         ENDIF
61074         LNAM=LIND
61075         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61076         NINDX=1
61077       ENDIF
61078       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61079         LIND=LNAM
61080   200   LIND=LIND+1
61081         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
61082         CHIND=' '
61083         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61084         READ(CHIND,'(I8)') I2
61085         LNAM=LIND
61086         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61087         NINDX=2
61088       ENDIF
61089       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61090         LIND=LNAM
61091   210   LIND=LIND+1
61092         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
61093         CHIND=' '
61094         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61095         READ(CHIND,'(I8)') I3
61096         LNAM=LIND+1
61097         NINDX=3
61098       ENDIF
61099  
61100 C...Check that indices allowed.
61101       IERR=0
61102       IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
61103       IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
61104      &IERR=2
61105       IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
61106      &IERR=3
61107       IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
61108      &IERR=4
61109       IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
61110       IF(IERR.GE.1) THEN
61111         CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
61112      &  CHBIT(1:LNAM-1))
61113         LLOW=LHIG
61114         IF(LLOW.LT.LTOT) GOTO 120
61115         RETURN
61116       ENDIF
61117  
61118 C...Save old value of variable.
61119       IF(IVAR.EQ.1) THEN
61120         IOLD=N
61121       ELSEIF(IVAR.EQ.2) THEN
61122         IOLD=K(I1,I2)
61123       ELSEIF(IVAR.EQ.3) THEN
61124         ROLD=P(I1,I2)
61125       ELSEIF(IVAR.EQ.4) THEN
61126         ROLD=V(I1,I2)
61127       ELSEIF(IVAR.EQ.5) THEN
61128         IOLD=MSTU(I1)
61129       ELSEIF(IVAR.EQ.6) THEN
61130         ROLD=PARU(I1)
61131       ELSEIF(IVAR.EQ.7) THEN
61132         IOLD=MSTJ(I1)
61133       ELSEIF(IVAR.EQ.8) THEN
61134         ROLD=PARJ(I1)
61135       ELSEIF(IVAR.EQ.9) THEN
61136         IOLD=KCHG(I1,I2)
61137       ELSEIF(IVAR.EQ.10) THEN
61138         ROLD=PMAS(I1,I2)
61139       ELSEIF(IVAR.EQ.11) THEN
61140         ROLD=PARF(I1)
61141       ELSEIF(IVAR.EQ.12) THEN
61142         ROLD=VCKM(I1,I2)
61143       ELSEIF(IVAR.EQ.13) THEN
61144         IOLD=MDCY(I1,I2)
61145       ELSEIF(IVAR.EQ.14) THEN
61146         IOLD=MDME(I1,I2)
61147       ELSEIF(IVAR.EQ.15) THEN
61148         ROLD=BRAT(I1)
61149       ELSEIF(IVAR.EQ.16) THEN
61150         IOLD=KFDP(I1,I2)
61151       ELSEIF(IVAR.EQ.17) THEN
61152         CHOLD=CHAF(I1,I2)(1:8)
61153       ELSEIF(IVAR.EQ.18) THEN
61154         IOLD=MRPY(I1)
61155       ELSEIF(IVAR.EQ.19) THEN
61156         ROLD=RRPY(I1)
61157       ELSEIF(IVAR.EQ.20) THEN
61158         IOLD=MSEL
61159       ELSEIF(IVAR.EQ.21) THEN
61160         IOLD=MSUB(I1)
61161       ELSEIF(IVAR.EQ.22) THEN
61162         IOLD=KFIN(I1,I2)
61163       ELSEIF(IVAR.EQ.23) THEN
61164         ROLD=CKIN(I1)
61165       ELSEIF(IVAR.EQ.24) THEN
61166         IOLD=MSTP(I1)
61167       ELSEIF(IVAR.EQ.25) THEN
61168         ROLD=PARP(I1)
61169       ELSEIF(IVAR.EQ.26) THEN
61170         IOLD=MSTI(I1)
61171       ELSEIF(IVAR.EQ.27) THEN
61172         ROLD=PARI(I1)
61173       ELSEIF(IVAR.EQ.28) THEN
61174         IOLD=MINT(I1)
61175       ELSEIF(IVAR.EQ.29) THEN
61176         ROLD=VINT(I1)
61177       ELSEIF(IVAR.EQ.30) THEN
61178         IOLD=ISET(I1)
61179       ELSEIF(IVAR.EQ.31) THEN
61180         IOLD=KFPR(I1,I2)
61181       ELSEIF(IVAR.EQ.32) THEN
61182         ROLD=COEF(I1,I2)
61183       ELSEIF(IVAR.EQ.33) THEN
61184         IOLD=ICOL(I1,I2,I3)
61185       ELSEIF(IVAR.EQ.34) THEN
61186         ROLD=XSFX(I1,I2)
61187       ELSEIF(IVAR.EQ.35) THEN
61188         IOLD=ISIG(I1,I2)
61189       ELSEIF(IVAR.EQ.36) THEN
61190         ROLD=SIGH(I1)
61191       ELSEIF(IVAR.EQ.37) THEN
61192         IOLD=MWID(I1)
61193       ELSEIF(IVAR.EQ.38) THEN
61194         ROLD=WIDS(I1,I2)
61195       ELSEIF(IVAR.EQ.39) THEN
61196         IOLD=NGEN(I1,I2)
61197       ELSEIF(IVAR.EQ.40) THEN
61198         ROLD=XSEC(I1,I2)
61199       ELSEIF(IVAR.EQ.41) THEN
61200         CHOLD2=PROC(I1)
61201       ELSEIF(IVAR.EQ.42) THEN
61202         ROLD=SIGT(I1,I2,I3)
61203       ELSEIF(IVAR.EQ.43) THEN
61204         ROLD=XPVMD(I1)
61205       ELSEIF(IVAR.EQ.44) THEN
61206         ROLD=XPANL(I1)
61207       ELSEIF(IVAR.EQ.45) THEN
61208         ROLD=XPANH(I1)
61209       ELSEIF(IVAR.EQ.46) THEN
61210         ROLD=XPBEH(I1)
61211       ELSEIF(IVAR.EQ.47) THEN
61212         ROLD=XPDIR(I1)
61213       ELSEIF(IVAR.EQ.48) THEN
61214         IOLD=IMSS(I1)
61215       ELSEIF(IVAR.EQ.49) THEN
61216         ROLD=RMSS(I1)
61217       ELSEIF(IVAR.EQ.50) THEN
61218         ROLD=RVLAM(I1,I2,I3)
61219       ELSEIF(IVAR.EQ.51) THEN
61220         ROLD=RVLAMP(I1,I2,I3)
61221       ELSEIF(IVAR.EQ.52) THEN
61222         ROLD=RVLAMB(I1,I2,I3)
61223       ELSEIF(IVAR.EQ.53) THEN
61224         IOLD=ITCM(I1)
61225       ELSEIF(IVAR.EQ.54) THEN
61226         ROLD=RTCM(I1)
61227       ELSEIF(IVAR.EQ.55) THEN
61228         IOLD=IUED(I1)
61229       ELSEIF(IVAR.EQ.56) THEN
61230         ROLD=RUED(I1)
61231       ENDIF
61232  
61233 C...Print current value of variable. Loop back.
61234       IF(LNAM.GE.LBIT) THEN
61235         CHBIT(LNAM:14)=' '
61236         CHBIT(15:60)=' has the value                                '
61237         IF(MSVAR(IVAR,1).EQ.1) THEN
61238           WRITE(CHBIT(51:60),'(I10)') IOLD
61239         ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61240           WRITE(CHBIT(47:60),'(F14.5)') ROLD
61241         ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61242           CHBIT(53:60)=CHOLD
61243         ELSE
61244           CHBIT(33:60)=CHOLD
61245         ENDIF
61246         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61247         LLOW=LHIG
61248         IF(LLOW.LT.LTOT) GOTO 120
61249         RETURN
61250       ENDIF
61251  
61252 C...Read in new variable value.
61253       IF(MSVAR(IVAR,1).EQ.1) THEN
61254         CHINI=' '
61255         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
61256         READ(CHINI,'(I10)') INEW
61257       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61258         CHINR=' '
61259         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
61260         READ(CHINR,*) RNEW
61261       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61262         CHNEW=CHBIT(LNAM+1:LBIT)//' '
61263       ELSE
61264         CHNEW2=CHBIT(LNAM+1:LBIT)//' '
61265       ENDIF
61266  
61267 C...Store new variable value.
61268       IF(IVAR.EQ.1) THEN
61269         N=INEW
61270       ELSEIF(IVAR.EQ.2) THEN
61271         K(I1,I2)=INEW
61272       ELSEIF(IVAR.EQ.3) THEN
61273         P(I1,I2)=RNEW
61274       ELSEIF(IVAR.EQ.4) THEN
61275         V(I1,I2)=RNEW
61276       ELSEIF(IVAR.EQ.5) THEN
61277         MSTU(I1)=INEW
61278       ELSEIF(IVAR.EQ.6) THEN
61279         PARU(I1)=RNEW
61280       ELSEIF(IVAR.EQ.7) THEN
61281         MSTJ(I1)=INEW
61282       ELSEIF(IVAR.EQ.8) THEN
61283         PARJ(I1)=RNEW
61284       ELSEIF(IVAR.EQ.9) THEN
61285         KCHG(I1,I2)=INEW
61286       ELSEIF(IVAR.EQ.10) THEN
61287         PMAS(I1,I2)=RNEW
61288       ELSEIF(IVAR.EQ.11) THEN
61289         PARF(I1)=RNEW
61290       ELSEIF(IVAR.EQ.12) THEN
61291         VCKM(I1,I2)=RNEW
61292       ELSEIF(IVAR.EQ.13) THEN
61293         MDCY(I1,I2)=INEW
61294       ELSEIF(IVAR.EQ.14) THEN
61295         MDME(I1,I2)=INEW
61296       ELSEIF(IVAR.EQ.15) THEN
61297         BRAT(I1)=RNEW
61298       ELSEIF(IVAR.EQ.16) THEN
61299         KFDP(I1,I2)=INEW
61300       ELSEIF(IVAR.EQ.17) THEN
61301         CHAF(I1,I2)=CHNEW
61302       ELSEIF(IVAR.EQ.18) THEN
61303         MRPY(I1)=INEW
61304       ELSEIF(IVAR.EQ.19) THEN
61305         RRPY(I1)=RNEW
61306       ELSEIF(IVAR.EQ.20) THEN
61307         MSEL=INEW
61308       ELSEIF(IVAR.EQ.21) THEN
61309         MSUB(I1)=INEW
61310       ELSEIF(IVAR.EQ.22) THEN
61311         KFIN(I1,I2)=INEW
61312       ELSEIF(IVAR.EQ.23) THEN
61313         CKIN(I1)=RNEW
61314       ELSEIF(IVAR.EQ.24) THEN
61315         MSTP(I1)=INEW
61316       ELSEIF(IVAR.EQ.25) THEN
61317         PARP(I1)=RNEW
61318       ELSEIF(IVAR.EQ.26) THEN
61319         MSTI(I1)=INEW
61320       ELSEIF(IVAR.EQ.27) THEN
61321         PARI(I1)=RNEW
61322       ELSEIF(IVAR.EQ.28) THEN
61323         MINT(I1)=INEW
61324       ELSEIF(IVAR.EQ.29) THEN
61325         VINT(I1)=RNEW
61326       ELSEIF(IVAR.EQ.30) THEN
61327         ISET(I1)=INEW
61328       ELSEIF(IVAR.EQ.31) THEN
61329         KFPR(I1,I2)=INEW
61330       ELSEIF(IVAR.EQ.32) THEN
61331         COEF(I1,I2)=RNEW
61332       ELSEIF(IVAR.EQ.33) THEN
61333         ICOL(I1,I2,I3)=INEW
61334       ELSEIF(IVAR.EQ.34) THEN
61335         XSFX(I1,I2)=RNEW
61336       ELSEIF(IVAR.EQ.35) THEN
61337         ISIG(I1,I2)=INEW
61338       ELSEIF(IVAR.EQ.36) THEN
61339         SIGH(I1)=RNEW
61340       ELSEIF(IVAR.EQ.37) THEN
61341         MWID(I1)=INEW
61342       ELSEIF(IVAR.EQ.38) THEN
61343         WIDS(I1,I2)=RNEW
61344       ELSEIF(IVAR.EQ.39) THEN
61345         NGEN(I1,I2)=INEW
61346       ELSEIF(IVAR.EQ.40) THEN
61347         XSEC(I1,I2)=RNEW
61348       ELSEIF(IVAR.EQ.41) THEN
61349         PROC(I1)=CHNEW2
61350       ELSEIF(IVAR.EQ.42) THEN
61351         SIGT(I1,I2,I3)=RNEW
61352       ELSEIF(IVAR.EQ.43) THEN
61353         XPVMD(I1)=RNEW
61354       ELSEIF(IVAR.EQ.44) THEN
61355         XPANL(I1)=RNEW
61356       ELSEIF(IVAR.EQ.45) THEN
61357         XPANH(I1)=RNEW
61358       ELSEIF(IVAR.EQ.46) THEN
61359         XPBEH(I1)=RNEW
61360       ELSEIF(IVAR.EQ.47) THEN
61361         XPDIR(I1)=RNEW
61362       ELSEIF(IVAR.EQ.48) THEN
61363         IMSS(I1)=INEW
61364       ELSEIF(IVAR.EQ.49) THEN
61365         RMSS(I1)=RNEW
61366       ELSEIF(IVAR.EQ.50) THEN
61367         RVLAM(I1,I2,I3)=RNEW
61368       ELSEIF(IVAR.EQ.51) THEN
61369         RVLAMP(I1,I2,I3)=RNEW
61370       ELSEIF(IVAR.EQ.52) THEN
61371         RVLAMB(I1,I2,I3)=RNEW
61372       ELSEIF(IVAR.EQ.53) THEN
61373         ITCM(I1)=INEW
61374       ELSEIF(IVAR.EQ.54) THEN
61375         RTCM(I1)=RNEW
61376       ELSEIF(IVAR.EQ.55) THEN
61377         IUED(I1)=INEW
61378       ELSEIF(IVAR.EQ.56) THEN
61379         RUED(I1)=RNEW
61380       ENDIF
61381  
61382 C...Write old and new value. Loop back.
61383       CHBIT(LNAM:14)=' '
61384       CHBIT(15:60)=' changed from                to               '
61385       IF(MSVAR(IVAR,1).EQ.1) THEN
61386         WRITE(CHBIT(33:42),'(I10)') IOLD
61387         WRITE(CHBIT(51:60),'(I10)') INEW
61388         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61389       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61390         WRITE(CHBIT(29:42),'(F14.5)') ROLD
61391         WRITE(CHBIT(47:60),'(F14.5)') RNEW
61392         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61393       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61394         CHBIT(35:42)=CHOLD
61395         CHBIT(53:60)=CHNEW
61396         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61397       ELSE
61398         CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
61399         IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
61400       ENDIF
61401       LLOW=LHIG
61402       IF(LLOW.LT.LTOT) GOTO 120
61403  
61404 C...Format statement for output on unit MSTU(11) (by default 6).
61405  5000 FORMAT(5X,A60)
61406  5100 FORMAT(5X,A88)
61407  
61408       RETURN
61409       END
61410  
61411 C*********************************************************************
61412  
61413 C...PYONOF
61414 C...Switches on and off decay channel by search for match.
61415  
61416       SUBROUTINE PYONOF(CHIN)
61417  
61418 C...Double precision and integer declarations.
61419       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61420       IMPLICIT INTEGER(I-N)
61421       INTEGER PYK,PYCHGE,PYCOMP
61422 C...Commonblocks.
61423       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61424       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
61425       SAVE /PYDAT1/,/PYDAT3/
61426 C...Local arrays and character variables.
61427       INTEGER KFCMP(10),KFTMP(10)
61428       CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
61429      &CHALP(2)*26
61430       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
61431      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
61432 
61433 C...Determine length of character variable.
61434       CHTMP=CHIN//' '
61435       LBEG=0
61436   100 LBEG=LBEG+1
61437       IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
61438       LEND=LBEG-1
61439   105 LEND=LEND+1
61440       IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
61441   110 LEND=LEND-1
61442       IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
61443       LEN=1+LEND-LBEG
61444       CHFIX(1:LEN)=CHTMP(LBEG:LEND)
61445 
61446 C...Find colon separator and particle code.
61447       LCOLON=0
61448   120 LCOLON=LCOLON+1
61449       IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
61450       CHCODE=' '
61451       CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
61452       READ(CHCODE,'(I8)',ERR=300) KF
61453       KC=PYCOMP(KF)
61454 
61455 C...Done if unknown code or no decay channels.
61456       IF(KC.EQ.0) THEN
61457         CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
61458         RETURN
61459       ENDIF
61460       IDCBEG=MDCY(KC,2)
61461       IDCLEN=MDCY(KC,3)
61462       IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
61463         CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
61464         RETURN
61465       ENDIF
61466 
61467 C...Find command name up to blank or equal sign.
61468       LSEP=LCOLON
61469   130 LSEP=LSEP+1
61470       IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
61471      &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
61472       CHMODE=' '
61473       LMODE=LSEP-LCOLON-1
61474       CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
61475 
61476 C...Convert to uppercase.
61477       DO 150 LCOM=1,LMODE
61478         DO 140 LALP=1,26
61479           IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) 
61480      &    CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
61481   140   CONTINUE
61482   150 CONTINUE
61483 
61484 C...Identify command. Failed if not identified.
61485       MODE=0
61486       IF(CHMODE.EQ.'ALLOFF') MODE=1
61487       IF(CHMODE.EQ.'ALLON') MODE=2
61488       IF(CHMODE.EQ.'OFFIFANY') MODE=3
61489       IF(CHMODE.EQ.'ONIFANY') MODE=4
61490       IF(CHMODE.EQ.'OFFIFALL') MODE=5
61491       IF(CHMODE.EQ.'ONIFALL') MODE=6
61492       IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
61493       IF(CHMODE.EQ.'ONIFMATCH') MODE=8
61494       IF(MODE.EQ.0) THEN
61495         CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
61496         RETURN
61497       ENDIF
61498 
61499 C...Simple cases when all on or all off.
61500       IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
61501         WRITE(MSTU(11),1000) KF,CHMODE
61502         DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
61503           IF(MDME(IDC,1).LT.0) GOTO 160
61504           MDME(IDC,1)=MODE-1
61505   160   CONTINUE
61506         RETURN
61507       ENDIF
61508 
61509 C...Identify matching list.
61510       NCMP=0
61511       LBEG=LSEP
61512   170 LBEG=LBEG+1
61513       IF(LBEG.GT.LEN) GOTO 190
61514       IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
61515      &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
61516       LEND=LBEG-1
61517   180 LEND=LEND+1
61518       IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
61519      &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
61520       IF(LEND.LT.LEN) LEND=LEND-1
61521       CHCODE=' '
61522       CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
61523       READ(CHCODE,'(I8)',ERR=300) KFREAD
61524       NCMP=NCMP+1
61525       KFCMP(NCMP)=IABS(KFREAD)
61526       LBEG=LEND
61527       IF(NCMP.LT.10) GOTO 170
61528   190 CONTINUE
61529       WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
61530 
61531 C...Only one matching required.
61532       IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
61533         DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
61534           IF(MDME(IDC,1).LT.0) GOTO 220
61535           DO 210 IKF=1,5
61536             KFNOW=IABS(KFDP(IDC,IKF))
61537             IF(KFNOW.EQ.0) GOTO 210
61538             DO 200 ICMP=1,NCMP
61539               IF(KFCMP(ICMP).EQ.KFNOW) THEN
61540                 MDME(IDC,1)=MODE-3
61541                 GOTO 220
61542               ENDIF
61543   200      CONTINUE
61544   210     CONTINUE
61545   220   CONTINUE
61546         RETURN
61547       ENDIF
61548 
61549 C...Multiple matchings required.
61550       DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
61551         IF(MDME(IDC,1).LT.0) GOTO 260
61552         NTMP=NCMP
61553         DO 230 ITMP=1,NTMP
61554           KFTMP(ITMP)=KFCMP(ITMP)
61555   230   CONTINUE  
61556         NFIN=0 
61557         DO 250 IKF=1,5
61558           KFNOW=IABS(KFDP(IDC,IKF))
61559           IF(KFNOW.EQ.0) GOTO 250
61560           NFIN=NFIN+1
61561           DO 240 ITMP=1,NTMP
61562             IF(KFTMP(ITMP).EQ.KFNOW) THEN
61563               KFTMP(ITMP)=KFTMP(NTMP) 
61564               NTMP=NTMP-1
61565               GOTO 250
61566             ENDIF
61567   240     CONTINUE
61568   250   CONTINUE
61569         IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
61570         IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7) 
61571      &  MDME(IDC,1)=MODE-7
61572   260 CONTINUE
61573       RETURN
61574 
61575 C...Error exit for impossible read of particle code.
61576   300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
61577      &//CHCODE)
61578 
61579 C...Formats for output.
61580  1000 FORMAT(' Decays for',I8,' set ',A10)
61581  1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
61582 
61583       RETURN
61584       END
61585 C*********************************************************************
61586  
61587 C...PYTUNE
61588 C...Presets for a few specific underlying-event and min-bias tunes
61589 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
61590 C...others require particular versions of pythia (e.g. the SCI and GAL
61591 C...models). See below for details.
61592       SUBROUTINE PYTUNE(MYTUNE)
61593 C
61594 C ITUNE    NAME (detailed descriptions below)
61595 C     0 Default : No settings changed => defaults.
61596 C
61597 C ====== Old UE, Q2-ordered showers ====================================
61598 C   100       A : Rick Field's CDF Tune A                     (Oct 2002)
61599 C   101      AW : Rick Field's CDF Tune AW                    (Apr 2006)
61600 C   102      BW : Rick Field's CDF Tune BW                    (Apr 2006)
61601 C   103      DW : Rick Field's CDF Tune DW                    (Apr 2006)
61602 C   104     DWT : As DW but with slower UE ECM-scaling        (Apr 2006)
61603 C   105      QW : Rick Field's CDF Tune QW using CTEQ6.1M            (?)
61604 C   106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome")          (?)
61605 C   107     ACR : Tune A modified with new CR model           (Mar 2007)
61606 C   108      D6 : Rick Field's CDF Tune D6 using CTEQ6L1             (?)
61607 C   109     D6T : Rick Field's CDF Tune D6T using CTEQ6L1            (?)
61608 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
61609 C   110   A-Pro : Tune A, with LEP tune from Professor        (Oct 2008)
61610 C   111  AW-Pro : Tune AW, -"-                                (Oct 2008)
61611 C   112  BW-Pro : Tune BW, -"-                                (Oct 2008)
61612 C   113  DW-Pro : Tune DW, -"-                                (Oct 2008)
61613 C   114 DWT-Pro : Tune DWT, -"-                               (Oct 2008)
61614 C   115  QW-Pro : Tune QW, -"-                                (Oct 2008)
61615 C   116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"-                  (Oct 2008)
61616 C   117 ACR-Pro : Tune ACR, -"-                               (Oct 2008)
61617 C   118  D6-Pro : Tune D6, -"-                                (Oct 2008)
61618 C   119 D6T-Pro : Tune D6T, -"-                               (Oct 2008)
61619 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
61620 C   129 Pro-Q2O : Professor Q2-ordered tune                   (Feb 2009)
61621 C ---- LHC tune variations on Pro-Q2O 
61622 C   136 Q12-F1  : Variation with wide fragmentation function (Mar 2012)
61623 C   137 Q12-F2  : Variation with narrow fragmentation function (Mar 2012)
61624 C
61625 C ====== Intermediate and Hybrid Models ================================
61626 C   200    IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
61627 C   201     APT : Tune A w. pT-ordered FSR                    (Mar 2007)
61628 C   211 APT-Pro : Tune APT, with LEP tune from Professor      (Oct 2008)
61629 C   221 Perugia APT  : "Perugia" update of APT-Pro            (Feb 2009)
61630 C   226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
61631 C
61632 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
61633 C   300      S0 : Sandhoff-Skands Tune using the S0 CR model  (Apr 2006)
61634 C   301      S1 : Sandhoff-Skands Tune using the S1 CR model  (Apr 2006)
61635 C   302      S2 : Sandhoff-Skands Tune using the S2 CR model  (Apr 2006)
61636 C   303     S0A : S0 with "Tune A" UE energy scaling          (Apr 2006)
61637 C   304    NOCR : New UE "best try" without col. rec.         (Apr 2006)
61638 C   305     Old : New UE, original (primitive) col. rec.      (Aug 2004)
61639 C   306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
61640 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
61641 C   310   S0-Pro : S0 with updated LEP pars from Professor    (Oct 2008)
61642 C   311   S1-Pro : S1 -"-                                     (Oct 2008)
61643 C   312   S2-Pro : S2 -"-                                     (Oct 2008)
61644 C   313  S0A-Pro : S0A -"-                                    (Oct 2008)
61645 C   314 NOCR-Pro : NOCR -"-                                   (Oct 2008)
61646 C   315  Old-Pro : Old -"-                                    (Oct 2008)
61647 C   316  ATLAS MC08 : pT-ordered showers, CTEQ6L1             (2008)
61648 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
61649 C   320 Perugia 0 : "Perugia" update of S0-Pro                (Feb 2009)
61650 C   321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
61651 C   322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
61652 C   323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
61653 C                   balance & different scaling to LHC & RHIC (Feb 2009)
61654 C   324 Perugia NOCR : "Perugia" update of NOCR-Pro           (Feb 2009)
61655 C   325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
61656 C   326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
61657 C   327 Perugia 10: Alternative to Perugia 0, with more FSR   (May 2010)
61658 C                   off ISR, more BR breakup, more strangeness
61659 C   328 Perugia K : Alternative to Perugia 2010, with a       (May 2010)   
61660 C                   K-factor applied to MPI cross sections
61661 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
61662 C   329 Pro-pTO   : Professor pT-ordered tune w. S0 CR model  (Feb 2009)
61663 C ---- Tunes introduced in 6.4.23:
61664 C   330 ATLAS MC09 : pT-ordered showers, LO* PDFs             (2009)
61665 C   331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
61666 C   334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI   (Oct 2010)
61667 C   335 Pro-pT*   : Professor Tune with LO*                   (Mar 2009)
61668 C   336 Pro-pT6   : Professor Tune with CTEQ6LL               (Mar 2009)
61669 C   339 Pro-pT**  : Professor Tune with LO**                  (Mar 2009)
61670 C   340 AMBT1   : First ATLAS tune including 7 TeV data       (May 2010)
61671 C   341 Z1      : First CMS tune including 7 TeV data         (Aug 2010)
61672 C   342 Z1-LEP  : CMS tune Z1, with improved LEP parameters   (Oct 2010)
61673 C   343 Z2      : Retune of Z1 by Field w CTEQ6L1 PDFs            (2010)
61674 C   344 Z2-LEP  : Retune of Z1 by Skands w CTEQ6L1 PDFs       (Feb 2011)
61675 C   345 AMBT2B-CT6L : 2nd ATLAS MB tune, vers 'B', w CTEQ6L1  (Jul 2011)
61676 C   346 AUET2B-CT6L : UE tune accompanying AMBT2B             (Jul 2011)
61677 C   347 AUET2B-CT66 : AUET2 with CTEQ 6.6 NLO PDFs            (Nov 2011)
61678 C   348 AUET2B-CT10 : AUET2 with CTEQ 10 NLO PDFs             (Nov 2011)
61679 C   349 AUET2B-NN21 : AUET2 with NNPDF 2.1 NLO PDFs           (Nov 2011)
61680 C   350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
61681 C   351 P2011 radHi : Variation with alphaS(pT/2) 
61682 C   352 P2011 radLo : Variation with alphaS(2pT)
61683 C   353 P2011 mpiHi : Variation with more semi-hard MPI
61684 C   354 P2011 noCR  : Variation without color reconnections
61685 C   355 P2011 LO**  : Perugia 2011 using MSTW LO** PDFs       (Mar 2011)
61686 C   356 P2011 C6    : Perugia 2011 using CTEQ6L1 PDFs         (Mar 2011)
61687 C   357 P2011 T16   : Variation with PARP(90)=0.32 away from 7 TeV
61688 C   358 P2011 T32   : Variation with PARP(90)=0.16 awat from 7 TeV
61689 C   359 P2011 TeV   : Perugia 2011 optimized for Tevatron     (Mar 2011)
61690 C   360 S Global    : Schulz-Skands Global fit                (Mar 2011)
61691 C   361 S 7000      : Schulz-Skands at 7000 GeV               (Mar 2011)
61692 C   362 S 1960      : Schulz-Skands at 1960 GeV               (Mar 2011)
61693 C   363 S 1800      : Schulz-Skands at 1800 GeV               (Mar 2011)
61694 C   364 S 900       : Schulz-Skands at 900 GeV                (Mar 2011)
61695 C   365 S 630       : Schulz-Skands at 630 GeV                (Mar 2011)
61696 C
61697 C   370 P12       : Retune of Perugia 2011 w CTEQ6L1          (Oct 2012)
61698 C   371 P12-radHi : Variation with alphaS(pT/2) 
61699 C   372 P12-radLo : Variation with alphaS(2pT)
61700 C   373 P12-mpiHi : Variation with more semi-hard MPI 
61701 C   374 P12-loCR  : Variation using lower CR strength -> more Nch
61702 C   375 P12-noCR  : Variation without any color reconnections
61703 C   376 P12-FL    : Variation with more longitudinal fragmentation
61704 C   377 P12-FT    : Variation with more transverse fragmentation
61705 C   378 P12-M8LO  : Variation using MSTW 2008 LO PDFs     
61706 C   379 P12-LO**  : Variation using MRST LO** PDFs     
61707 C   380 P12-val0  : Variation with PARP(87)=0D0               (Jul 2013)
61708 C   381 P12-ueHi  : Variation with lower pT0 (more soft UE activity)
61709 C   382 P12-ueLo  : Variation with higher pT0 (less soft UE activity)
61710 C   383 P12-IBK   : Perugia 2012 with Innsbruck ee fragmentation parameters
61711 
61712 C   390 IBK-CTEQ5L    : Innsbruck pp tune with CTEQ5 LO PDFs  (Jul 2013)
61713 C   391 IBK-CTEQ6LL   :    with CTEQ6LL LO PDFs
61714 C   392 IBK-MSTW08LO  :    with MSTW08 LO PDFS
61715 C   393 IBK-CTEQ66NLO :    with CTEQ6 NLO PDFs
61716 C   394 IBK-CT10NLO   :    with CT10 NLO PDFs
61717 C   395 IBK-MSTW08NLO :    with MSTW08 NLO PDFs
61718 C   396 IBK-MSTW08LO* :    with MSTW07 LO* PDFs
61719 C   397 IBK-MRSTLO**  :    with MRSTMCal (LO**) PDFs
61720 C   398 IBK-CT09MC2   :    with CTEQ09MC2 PDFs  
61721 
61722 C ======= The Uppsala models ===========================================
61723 C  1201   SCI 0 : Soft-Colour-Interaction model. Org pars     (Dec 1998)
61724 C  1202   SCI 1 : SCI 0. Tevatron MB retuned (Skands)         (Oct 2006)
61725 C  1401   GAL 0 : Generalized area-law model. Org pars        (Dec 1998)
61726 C  1402   GAL 1 : GAL 0. Tevatron MB retuned (Skands)         (Oct 2006)
61727 C
61728 C More details;
61729 C
61730 C Quick Dictionary:
61731 C      BE : Bose-Einstein
61732 C      BR : Beam Remnants
61733 C      CR : Colour Reconnections
61734 C      HAD: Hadronization
61735 C      ISR/FSR: Initial-State Radiation / Final-State Radiation
61736 C      FSI: Final-State Interactions (=CR+BE)
61737 C      MB : Minimum-bias
61738 C      MI : Multiple Interactions
61739 C      UE : Underlying Event
61740 C
61741 C=======================================================================
61742 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
61743 C=======================================================================
61744 C
61745 C   A (100) and AW (101). CTEQ5L parton distributions
61746 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61747 C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
61748 C...Key feature: extensively compared to CDF data (R.D. Field).
61749 C...* Large starting scale for ISR (PARP(67)=4)
61750 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
61751 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61752 C
61753 C   BW (102). CTEQ5L parton distributions
61754 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61755 C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
61756 C...Key feature: extensively compared to CDF data (R.D. Field).
61757 C...NB: Can also be run with Pythia 6.2 or 6.312+
61758 C...* Small starting scale for ISR (PARP(67)=1)
61759 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
61760 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61761 C
61762 C   DW (103) and DWT (104). CTEQ5L parton distributions
61763 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61764 C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
61765 C...Key feature: extensively compared to CDF data (R.D. Field).
61766 C...NB: Can also be run with Pythia 6.2 or 6.312+
61767 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
61768 C...* DWT has a different reference energy, the same as the "S" models
61769 C...  below, leading to more UE activity at the LHC, but less at RHIC.
61770 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61771 C
61772 C   QW (105). CTEQ61 parton distributions
61773 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61774 C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
61775 C...Key feature: uses CTEQ61 (external pdf library must be linked)
61776 C
61777 C   ATLAS-DC2 (106). CTEQ5L parton distributions
61778 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61779 C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
61780 C...Key feature: tune used by the ATLAS collaboration.
61781 C
61782 C   ACR (107). CTEQ5L parton distributions
61783 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+    ***
61784 C...Key feature: Tune A modified to use annealing CR.
61785 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
61786 C
61787 C   D6 (108) and D6T (109). CTEQ6L parton distributions
61788 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
61789 C
61790 C   A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
61791 C   Old UE model, Q2-ordered showers.
61792 C...Key feature: Rick Field's family of tunes revamped with the
61793 C...Professor Q2-ordered final-state shower and fragmentation tunes
61794 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
61795 C...Key feature: improved descriptions of LEP data.
61796 C
61797 C   Pro-Q2O (129). CTEQ5L parton distributions
61798 C   Old UE model, Q2-ordered showers.
61799 C...Key feature: Complete retune of old model by Professor, including
61800 C...large amounts of both LEP and Tevatron data.
61801 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
61802 C...extreme in this tune, corresponding to using mu_R = pT/3 .
61803 C
61804 C=======================================================================
61805 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
61806 C=======================================================================
61807 C
61808 C   IM1 (200). Intermediate model, Q2-ordered showers,
61809 C   CTEQ5L parton distributions
61810 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
61811 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
61812 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
61813 C
61814 C   APT (201). Old UE model, pT-ordered final-state showers,
61815 C   CTEQ5L parton distributions
61816 C...Key feature: Rick Field's Tune A, but with new final-state showers
61817 C
61818 C   APT-Pro (211). Old UE model, pT-ordered final-state showers,
61819 C   CTEQ5L parton distributions
61820 C...Key feature: APT revamped with the Professor pT-ordered final-state
61821 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
61822 C...Perugia MPI workshop in October 2008.
61823 C
61824 C   Perugia-APT (221). Old UE model, pT-ordered final-state showers,
61825 C   CTEQ5L parton distributions
61826 C...Key feature: APT-Pro with final-state showers off the MPI,
61827 C...lower ISR renormalization scale to improve agreement with the
61828 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
61829 C...to min-bias at 630 GeV.
61830 C
61831 C   Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
61832 C   CTEQ6L1 parton distributions.
61833 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
61834 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
61835 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
61836 C
61837 C=======================================================================
61838 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
61839 C=======================================================================
61840 C
61841 C   S0 (300) and S0A (303). CTEQ5L parton distributions
61842 C...Key feature: large amount of multiple interactions
61843 C...* Somewhat faster than the other colour annealing scenarios.
61844 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
61845 C...  from Tune A, leading to less UE at the LHC, but more at RHIC.
61846 C...* Small amount of radiation.
61847 C...* Large amount of low-pT MI
61848 C...* Low degree of proton lumpiness (broad matter dist.)
61849 C...* CR Type S (driven by free triplets), of medium strength.
61850 C...* See: Pythia6402 update notes or later.
61851 C
61852 C   S1 (301). CTEQ5L parton distributions
61853 C...Key feature: large amount of radiation.
61854 C...* Large amount of low-pT perturbative ISR
61855 C...* Large amount of FSR off ISR partons
61856 C...* Small amount of low-pT multiple interactions
61857 C...* Moderate degree of proton lumpiness
61858 C...* Least aggressive CR type (S+S Type I), but with large strength
61859 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61860 C
61861 C   S2 (302). CTEQ5L parton distributions
61862 C...Key feature: very lumpy proton + gg string cluster formation allowed
61863 C...* Small amount of radiation
61864 C...* Moderate amount of low-pT MI
61865 C...* High degree of proton lumpiness (more spiky matter distribution)
61866 C...* Most aggressive CR type (S+S Type II), but with small strength
61867 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61868 C
61869 C   NOCR (304). CTEQ5L parton distributions
61870 C...Key feature: no colour reconnections (NB: "Best fit" only).
61871 C...* NB: <pT>(Nch) problematic in this tune.
61872 C...* Small amount of radiation
61873 C...* Small amount of low-pT MI
61874 C...* Low degree of proton lumpiness
61875 C...* Large BR composite x enhancement factor
61876 C...* Most clever colour flow without CR ("Lambda ordering")
61877 C
61878 C   ATLAS-CSC (306). CTEQ6L parton distributions
61879 C...Key feature: 11-parameter ATLAS tune of the new framework.
61880 C...* Old (pre-annealing) colour reconnections a la 305.
61881 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61882 C
61883 C   S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
61884 C...Key feature: the S0 family of tunes revamped with the Professor
61885 C...pT-ordered final-state shower and fragmentation tunes presented by
61886 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
61887 C...Key feature: improved descriptions of LEP data.
61888 C
61889 C   ATLAS MC08 (316). CTEQ6L1 parton distributions
61890 C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
61891 C...* Warning: uses Peterson fragmentation function for heavy quarks
61892 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61893 C
61894 C   Perugia-0 (320). CTEQ5L parton distributions.
61895 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
61896 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
61897 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
61898 C...beam-remnant breakup (more baryon number transport), and suppression
61899 C...of CR in high-pT string pieces.
61900 C
61901 C   Perugia-HARD (321). CTEQ5L parton distributions.
61902 C...Key feature: More ISR, More FSR, Less MPI, Less BR
61903 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
61904 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
61905 C...baryon number transport), and more fragmentation pT.
61906 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
61907 C...DY pT spectrum is HARD.
61908 C
61909 C   Perugia-SOFT (322). CTEQ5L parton distributions.
61910 C...Key feature: Less ISR, Less FSR, More MPI, More BR
61911 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
61912 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61913 C...number transport), and less fragmentation pT.
61914 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61915 C...DY pT spectrum is SOFT
61916 C
61917 C   Perugia-3 (323). CTEQ5L parton distributions.
61918 C...Key feature: variant of Perugia-0 with more extreme energy scaling
61919 C...properties while still agreeing with Tevatron data from 630 to 1960.
61920 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61921 C...allows FSR off the active end of dipoles stretched to the remnant.
61922 C
61923 C   Perugia-NOCR (324). CTEQ5L parton distributions.
61924 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61925 C...lower energies and somewhat better agreement with Tevatron data
61926 C...at 1800/1960.
61927 C
61928 C   Perugia-* (325). MRST LO* parton distributions for generators
61929 C...Key feature: first attempt at using the LO* distributions
61930 C...(external pdf library must be linked).
61931 C
61932 C   Perugia-6 (326). CTEQ6L1 parton distributions
61933 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61934 C
61935 C   Perugia-2010 (327). CTEQ5L parton distributions
61936 C...Key feature: Retune of Perugia 0 to attempt to better describe 
61937 C...strangeness yields at RHIC and at LEP. Also increased the amount 
61938 C...of FSR off ISR following the conclusions in arXiv:1001.4082. 
61939 C...Increased the amount of beam blowup, causing more baryon transport
61940 C...into the detector, to further explore this possibility. Using 
61941 C...a new color-reconnection model that relies on determining a thrust
61942 C...axis for the events and then computing reconnection probabilities for
61943 C...the individual string pieces based on the actual string densities
61944 C...per rapidity interval along that thrust direction.
61945 C
61946 C   Perugia-K (328). CTEQ5L parton distributions 
61947 C...Key feature: uses a ``K'' factor on the MPI cross sections
61948 C...This gives a larger rate of minijets and pushes the underlying-event 
61949 C...activity towards higher pT. To compensate for the increased activity 
61950 C...at higher pT, the infared regularization scale is larger for this tune.
61951 C
61952 C   Pro-pTO (329). CTEQ5L parton distributions
61953 C...Key feature: Complete retune of new model by Professor, including
61954 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61955 C
61956 C   ATLAS MC09 (330). LO* parton distributions
61957 C...Key feature: Good overall agreement with Tevatron and early LHC data.
61958 C...Similar to Perugia *.
61959 C
61960 C   ATLAS MC09c (331). LO* parton distributions
61961 C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
61962 C...Similar to Perugia *. Retuned CR model with respect to MC09.
61963 C
61964 C   Pro-pT* (335) LO* parton distributions
61965 C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
61966 C
61967 C   Pro-pT6 (336). CTEQ6L1 parton distributions
61968 C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
61969 C
61970 C   Pro-pT** (339). LO** parton distributions
61971 C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
61972 C
61973 C   AMBT1 (340). LO* parton distributions
61974 C...Key feature: First ATLAS tune including 7-TeV LHC data.
61975 C...Mainly retuned CR and mass distribution with respect to MC09c.
61976 C...Note: cannot be run standalone since it uses external PDFs.
61977 C
61978 C   CMSZ1 (341). CTEQ5L parton distributions
61979 C...Key feature: First CMS tune including 7-TeV LHC data.
61980 C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs, 
61981 C...has a lower pT0 at the Tevatron, which scales faster with energy. 
61982 C
61983 C   Z1-LEP (342). CTEQ5L parton distributions
61984 C...Key feature: CMS tune Z1 with improved LEP parameters, mostly 
61985 C...taken from the Professor/Perugia tunes, with a few minor updates.
61986 C
61987 C...More recent Perugia tunes: see arXiv:1005.3457
61988 C
61989 C...Schulz-Skands tunes: see arXiv:1103.3649 
61990 
61991  
61992 C...Global statements
61993       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61994       INTEGER PYK,PYCHGE,PYCOMP
61995  
61996 C...Commonblocks.
61997       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61998       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61999  
62000 C...SAVE statements
62001       SAVE /PYDAT1/,/PYPARS/
62002 
62003 C...Internal parameters
62004       PARAMETER(MXTUNS=500)
62005       CHARACTER*8 CHDOC
62006       PARAMETER (CHDOC='Aug 2013')
62007       CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
62008       CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
62009      &    CHPARJ(100), CHMSTU(101:121), CHPARU(101:121)
62010       CHARACTER*60 CH60
62011       CHARACTER*70 CH70
62012       DATA (CHNAMS(I),I=0,1)/'Default',' '/
62013       DATA (CHNAMS(I),I=100,119)/
62014      &    'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
62015      &    'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
62016      1    'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
62017      1    'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
62018      1    'Tune D6-Pro','Tune D6T-Pro'/
62019       DATA (CHNAMS(I),I=120,129)/
62020      &     9*' ','Pro-Q2O'/
62021       DATA (CHNAMS(I),I=130,139)/
62022      &     'Q12','Q12-radHi','Q12-radLo','Q12-mpiHi','Q12-noCR',
62023      &     'Q12-M','Q12-F1','Q12-F2','Q12-LE','Q12-TeV'/
62024       DATA (CHNAMS(I),I=300,309)/
62025      &    'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
62026      5    'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
62027       DATA (CHNAMS(I),I=310,316)/
62028      &    'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
62029      &    'NOCR-Pro','Old-Pro','ATLAS MC08'/
62030       DATA (CHNAMS(I),I=320,329)/
62031      &    'Perugia 0','Perugia HARD','Perugia SOFT',
62032      &    'Perugia 3','Perugia NOCR','Perugia LO*',
62033      &    'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
62034       DATA (CHNAMS(I),I=330,349)/
62035      &     'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
62036      &     'Pro-PT6',' ',' ','Pro-PT**',
62037      4     'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
62038      4     'AMBT2B-CT6L1','AUET2B-CT6L1','AUET2B-CT66','AUET2B-CT10',
62039      4     'AUET2B-NN21'/
62040       DATA (CHNAMS(I),I=350,359)/
62041      &     'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
62042      &     'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
62043      &     'P2011 T16','P2011 T32','P2011 Tevatron'/
62044       DATA (CHNAMS(I),I=360,369)/
62045      &     'S Global','S 7000','S 1960','S 1800',
62046      &     'S 900','S 630', 4*' '/
62047       DATA (CHNAMS(I),I=370,379)/
62048      &     'P12','P12-radHi','P12-radLo','P12-mpiHi','P12-loCR',
62049      &     'P12-noCR','P12-FL','P12-FT','P12-M8LO','P12-LO**'/
62050       DATA (CHNAMS(I),I=380,399)/
62051      &     'P12-val0','P12-ueHi','P12-ueLo','P12-IBK',6*' ',
62052      9     'Innsbruck C5LO','Innsbruck C6LO','Innsbruck M8LO',
62053      &     'Innsbruck C66NLO','Innsbruck C10NLO',
62054      &     'Innsbruck M8NLO','Innsbruck LO*','Innsbruck LO**',
62055      &     'Innsbruck C9MC2',
62056      &     ' '/
62057       DATA (CHNAMS(I),I=200,229)/
62058      &    'IM Tune 1','Tune APT',8*' ',
62059      &    ' ','Tune APT-Pro',8*' ',
62060      &    ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
62061       DATA (CHNAMS(I),I=400,409)/
62062      &    'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
62063       DATA (CHMSTJ(I),I=11,20)/
62064      &    'HAD choice of fragmentation function(s)',4*' ',
62065      &    'HAD treatment of small-mass systems',4*' '/
62066       DATA (CHMSTJ(I),I=41,50)/
62067      &    'FSR type (Q2 or pT) for old framework',9*' '/
62068       DATA (CHMSTP(I),I=1,10)/
62069      &    2*' ','INT switch for choice of LambdaQCD',7*' '/
62070       DATA (CHMSTP(I),I=31,40)/
62071      &    2*' ','"K" switch for K-factor on/off & type',7*' '/
62072       DATA (CHMSTP(I),I=51,100)/
62073      5    'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
62074      6    'ISR master switch',2*' ','ISR alphaS type',2*' ',
62075      6    'ISR coherence option for 1st emission',
62076      6    'ISR phase space choice & ME corrections',' ',
62077      7    'ISR IR regularization scheme',' ',
62078      7    'IFSR scheme for non-decay FSR',8*' ',
62079      8    'UE model',
62080      8    'UE hadron transverse mass distribution',5*' ',
62081      8    'BR composite scheme','BR color scheme',
62082      9    'BR primordial kT compensation',
62083      9    'BR primordial kT distribution',
62084      9    'BR energy partitioning scheme',2*' ',
62085      9    'FSI color (re-)connection model',5*' '/
62086       DATA (CHPARP(I),I=1,10)/
62087      &    'ME/UE LambdaQCD',9*' '/
62088       DATA (CHPARP(I),I=31,40)/
62089      &    ' ','"K" K-factor',8*' '/
62090       DATA (CHPARP(I),I=61,100)/
62091      6     'ISR LambdaQCD','ISR IR cutoff',' ',
62092      6     'ISR renormalization scale prefactor',
62093      6     2*' ','ISR Q2max factor',3*' ',
62094      7     'IFSR Q2max factor in non-s-channel procs',
62095      7     'IFSR LambdaQCD (outside resonance decays)',4*' ',
62096      7     'FSI color reco high-pT damping strength',
62097      7     'FSI color reconnection strength',
62098      7     'BR composite x enhancement','BR breakup suppression',
62099      8     2*'UE IR cutoff at reference ecm',
62100      8     2*'UE mass distribution parameter',
62101      8     'UE gg color correlated fraction','UE total gg fraction',
62102      8     'UE qq enhancement at low pT','UE qq enh scale / pT0',
62103      8     'UE IR cutoff reference ecm',
62104      8     'UE IR cutoff ecm scaling power',
62105      9     'BR primordial kT width <|kT|>',' ',
62106      9     'BR primordial kT UV cutoff',7*' '/
62107       DATA (CHPARJ(I),I=1,30)/
62108      &     'HAD diquark suppression','HAD strangeness suppression',
62109      &     'HAD strange diquark suppression',
62110      &     'HAD vector diquark suppression','HAD P(popcorn)',
62111      &     'HAD extra popcorn B(s)-M-B(s) supp',
62112      &     'HAD extra popcorn B-M(s)-B supp',
62113      &     3*' ',
62114      1     'HAD P(vector meson), u and d only',
62115      1     'HAD P(vector meson), contains s',
62116      1     'HAD P(vector meson), heavy quarks',
62117      1     'HAD P(L=1;S=0,J=1)','HAD P(L=1;S=1,J=0)',
62118      1     'HAD P(L=1;S=1,J=1)','HAD P(L=1;S=1,J=2)', 
62119      1     'HAD extra spin-3/2 baryon supp',
62120      1     'HAD extra leading-baryon supp',' ',
62121      2     'HAD fragmentation pT',' ',' ',' ',
62122      2     'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
62123       DATA (CHPARJ(I),I=41,90)/
62124      4     'HAD string parameter a(Meson)','HAD string parameter b',
62125      4     2*' ','HAD string a(Baryon)-a(Meson)',
62126      4     'HAD Lund(=0)-Bowler(=1) rQ (rc)',
62127      4     'HAD Lund(=0)-Bowler(=1) rb',3*' ',
62128      5     3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
62129      6     10*' ',10*' ',
62130      8     'FSR LambdaQCD (inside resonance decays)',
62131      &     'FSR IR cutoff',8*' '/
62132       DATA (CHMSTU(I),I=111,120)/
62133      1     ' ','INT n(flavors) for LambdaQCD',8*' '/
62134       DATA (CHPARU(I),I=111,120)/
62135      1     ' ','INT LambdaQCD',8*' '/
62136       
62137 C...1) Shorthand notation
62138       M13=MSTU(13)
62139       M11=MSTU(11)
62140       IF (MYTUNE.LE.MXTUNS.AND.MYTUNE.GE.0) THEN
62141         CHNAME=CHNAMS(MYTUNE)
62142         IF (MYTUNE.EQ.0) GOTO 9999
62143       ELSE
62144         CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
62145         GOTO 9999
62146       ENDIF
62147       
62148 C...  2) Hello World
62149       IF (M13.GE.1) WRITE(M11,5000) CHDOC
62150       
62151 C...  Hardcode some defaults
62152 C...  Get Lambda from PDF
62153       MSTP(3)  =  2
62154 C...  CTEQ5L1 PDFs
62155       MSTP(52) =  1
62156       MSTP(51) =  7
62157 C...  No K-factor 
62158       MSTP(33) =  0
62159 C...  Low-pT qq enhancement factor and pT/pT0 ratio
62160       PARP(87) = 0.7D0
62161       PARP(88) = 0.5D0
62162 C...  Hard-initialize L=1 meson rates to old default: 0.0
62163       PARJ(14) = 0D0
62164       PARJ(15) = 0D0
62165       PARJ(16) = 0D0
62166       PARJ(17) = 0D0
62167 
62168 C...  3) Tune parameters
62169       ITUNE = MYTUNE
62170  
62171 C=======================================================================
62172 C...ATLAS MC08
62173 
62174       IF (ITUNE.EQ.316) THEN
62175         
62176         IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62177         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62178           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62179      &        ' with tune.')
62180         ENDIF
62181 
62182 C...First set some explicit defaults from 6.4.20
62183 C...# Old defaults
62184         MSTJ(11) = 4
62185 C...# Old default flavour parameters
62186         PARJ(1)  =   0.1
62187         PARJ(2)  =   0.3  
62188         PARJ(3)  =   0.40 
62189         PARJ(4)  =   0.05 
62190         PARJ(11) =   0.5  
62191         PARJ(12) =   0.6 
62192         PARJ(21) = 0.36
62193         PARJ(41) = 0.30
62194         PARJ(42) = 0.58
62195         PARJ(46) = 1.0
62196         PARJ(82) = 1.0
62197 
62198 C...PDFs: CTEQ6L1 for 326
62199         MSTP(52)=2
62200         MSTP(51)=10042
62201 
62202 C...UE and ISR switches
62203         MSTP(81)=21
62204         MSTP(82)=4
62205         MSTP(70)=0
62206         MSTP(72)=1
62207 
62208 C...CR:
62209         MSTP(95)=2
62210         PARP(78)=0.3
62211         PARP(77)=0.0
62212         PARP(80)=0.1
62213 
62214 C...Primordial kT
62215         PARP(91)=2.0D0
62216         PARP(93)=5.0D0
62217 
62218 C...MPI:
62219         PARP(82)=2.1
62220         PARP(83)=0.8
62221         PARP(84)=0.7
62222         PARP(89)=1800.0
62223         PARP(90)=0.16
62224 
62225 C...FSR inside resonance decays
62226         PARJ(81)=0.29
62227 
62228 C...Fragmentation (warning: uses Peterson)
62229         MSTJ(11)=3   
62230         PARJ(54)=-0.07
62231         PARJ(55)=-0.006
62232         
62233         IF (M13.GE.1) THEN
62234           CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62235           WRITE(M11,5030) CH60
62236           CH60='Physics model: '//
62237      &         'T. Sjostrand & P. Skands, hep-ph/0408302'
62238           WRITE(M11,5030) CH60
62239           CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
62240           WRITE(M11,5030) CH60
62241           
62242 C...Output
62243           WRITE(M11,5030) ' '
62244           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62245           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62246           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
62247           IF (MSTP(70).EQ.0) THEN
62248             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62249           ENDIF
62250           WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62251           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62252           WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62253           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62254           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62255           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62256           WRITE(M11,5030) CH60
62257           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62258           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)          
62259           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62260           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62261           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62262           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62263           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62264           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62265           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62266           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62267           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62268           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62269           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62270           IF (MSTP(82).GE.2) THEN
62271             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
62272             IF (PARP(87).GE.0D0) 
62273      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
62274           ENDIF
62275           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62276           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62277           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62278           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62279           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62280           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62281           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62282           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62283           IF (MSTP(95).GE.1) THEN
62284             WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62285             IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62286           ENDIF
62287 
62288         ENDIF
62289  
62290 C=======================================================================
62291 C...ATLAS MC09, MC09c, AMBT1, AMBT2B, AUET2B + NLO PDF vars
62292 C...CMS Z1 (R. Field), Z1-LEP
62293 
62294       ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
62295      &       ITUNE.GE.341.AND.ITUNE.LE.349) THEN
62296         
62297         IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62298         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62299           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62300      &        ' with tune.')
62301         ENDIF
62302 
62303 C...pT-ordered shower default for everything
62304         MSTJ(41) = 12
62305 
62306 C...FSR inside resonance decays, base value (modified by individual tunes)
62307         PARJ(81) = 0.29
62308 
62309 C...First set some explicit defaults from 6.4.20
62310         IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
62311 C...  # Old defaults
62312           MSTJ(11) = 4
62313 C...# Old default flavour parameters
62314           PARJ(1)  =   0.1
62315           PARJ(2)  =   0.3  
62316           PARJ(3)  =   0.40 
62317           PARJ(4)  =   0.05 
62318           PARJ(11) =   0.5  
62319           PARJ(12) =   0.6 
62320           PARJ(21) = 0.36
62321           PARJ(41) = 0.30
62322           PARJ(42) = 0.58
62323           PARJ(46) = 1.0
62324           PARJ(82) = 1.0
62325         ELSE IF (ITUNE.LE.344) THEN
62326 C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
62327           PARJ( 1) = 0.08D0
62328           PARJ( 2) = 0.21D0
62329           PARJ( 3) = 0.94
62330           PARJ( 4) = 0.04D0
62331           PARJ(11) = 0.35D0
62332           PARJ(12) = 0.35D0
62333           PARJ(13) = 0.54
62334           PARJ(25) = 0.63
62335           PARJ(26) = 0.12
62336 C...# Switch on Bowler:
62337           MSTJ(11) = 5
62338 C...# Fragmentation
62339           PARJ(21) = 0.34D0
62340           PARJ(41) = 0.35D0
62341           PARJ(42) = 0.80D0
62342           PARJ(47) = 1.0
62343           PARJ(81) = 0.26D0
62344           PARJ(82) = 1.0D0
62345         ELSE 
62346 C... A*T2 tunes, from ATL-PHYS-PUB-2011-008
62347           PARJ( 1) = 0.073
62348           PARJ( 2) = 0.202
62349           PARJ( 3) = 0.950
62350           PARJ( 4) = 0.033
62351           PARJ(11) = 0.309
62352           PARJ(12) = 0.402
62353           PARJ(13) = 0.544
62354           PARJ(25) = 0.628
62355           PARJ(26) = 0.129
62356 C...# Switch on Bowler:
62357           MSTJ(11) = 5
62358 C...  # Fragmentation
62359           PARJ(21) = 0.30
62360           PARJ(41) = 0.368
62361           PARJ(42) = 1.004
62362           PARJ(47) = 0.873
62363           PARJ(81) = 0.256
62364           PARJ(82) = 0.830
62365         ENDIF
62366 
62367 C...Default scales and alphaS choices
62368         IF (ITUNE.GE.345) THEN
62369           MSTP(3) = 1
62370           PARU(112) = 0.192
62371           PARP(1)   = 0.192
62372           PARP(61)  = 0.192
62373         ENDIF
62374 
62375 C...PDFs: MRST LO* 
62376         MSTP(52) = 2
62377         MSTP(51) = 20650
62378         IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62379 C...Z1 uses CTEQ5L
62380           MSTP(52) = 1
62381           MSTP(51) = 7
62382         ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62383 C...Z2 uses CTEQ6L
62384           MSTP(52) = 2
62385           MSTP(51) = 10042
62386         ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN 
62387 C...AMBT2B, AUET2B use CTEQ6L1 
62388           MSTP(52) = 2
62389           MSTP(51) = 10042          
62390         ELSEIF (ITUNE.EQ.347) THEN 
62391 C...AUET2B-CT66 uses CTEQ66 NLO PDFs
62392           MSTP(52) = 2
62393           MSTP(51) = 10550
62394         ELSEIF (ITUNE.EQ.348) THEN 
62395 C...AUET2B-CT10 uses CTEQ10 NLO PDFs
62396           MSTP(52) = 2
62397           MSTP(51) = 10800
62398         ELSEIF (ITUNE.EQ.349) THEN 
62399 C...AUET2B-NN21 uses NNPDF 2.1 NLO PDF
62400           MSTP(52) = 2
62401           MSTP(51) = 192800
62402         ENDIF
62403 
62404 C...UE and ISR switches
62405         MSTP(81) = 21
62406         MSTP(82) = 4
62407         MSTP(70) = 0
62408         MSTP(72) = 1
62409 
62410 C...CR:
62411         MSTP(95) = 6
62412         PARP(78) = 0.3
62413         PARP(77) = 0.0
62414         PARP(80) = 0.1
62415         IF (ITUNE.EQ.331) THEN
62416           PARP(78) = 0.224          
62417         ELSEIF (ITUNE.EQ.340) THEN
62418 C...AMBT1
62419           PARP(77) = 1.016D0
62420           PARP(78) = 0.538D0
62421         ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62422 C...Z1 and Z2 use the AMBT1 CR values
62423           PARP(77) = 1.016D0
62424           PARP(78) = 0.538D0
62425         ELSEIF (ITUNE.EQ.345) THEN
62426 C...AMBT2B
62427           PARP(77) = 0.357D0
62428           PARP(78) = 0.235D0
62429         ELSEIF (ITUNE.EQ.346) THEN
62430 C...AUET2B
62431           PARP(77) = 0.491D0
62432           PARP(78) = 0.311D0
62433         ELSEIF (ITUNE.EQ.347) THEN
62434 C...AUET2B-CT66
62435           PARP(77) = 0.505D0
62436           PARP(78) = 0.385D0
62437         ELSEIF (ITUNE.EQ.348) THEN
62438 C...AUET2B-CT10
62439           PARP(77) = 0.125D0
62440           PARP(78) = 0.309D0
62441         ELSEIF (ITUNE.EQ.349) THEN
62442 C...AUET2B-NN21
62443           PARP(77) = 0.498D0
62444           PARP(78) = 0.354D0
62445         ENDIF
62446 
62447 C...MPI:
62448         PARP(82) = 2.3
62449         PARP(83) = 0.8
62450         PARP(84) = 0.7
62451         PARP(89) = 1800.0
62452         PARP(90) = 0.25
62453         IF (ITUNE.EQ.331) THEN
62454           PARP(82) = 2.315
62455           PARP(90) = 0.2487
62456         ELSEIF (ITUNE.EQ.340) THEN
62457           PARP(82) = 2.292D0
62458           PARP(83) = 0.356D0
62459           PARP(84) = 0.651
62460           PARP(90) = 0.25D0
62461         ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62462           PARP(82) = 1.932D0
62463           PARP(83) = 0.356D0
62464           PARP(84) = 0.651
62465           PARP(90) = 0.275D0
62466         ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62467           PARP(82) = 1.832D0
62468           PARP(83) = 0.356D0
62469           PARP(84) = 0.651
62470           PARP(90) = 0.275D0
62471         ELSEIF (ITUNE.EQ.345) THEN
62472           PARP(82) = 2.34
62473           PARP(83) = 0.356
62474           PARP(84) = 0.605
62475           PARP(90) = 0.246
62476         ELSEIF (ITUNE.EQ.346) THEN
62477           PARP(82) = 2.26
62478           PARP(83) = 0.356
62479           PARP(84) = 0.443
62480           PARP(90) = 0.249
62481         ELSEIF (ITUNE.EQ.347) THEN
62482           PARP(82) = 1.87
62483           PARP(83) = 0.356
62484           PARP(84) = 0.561
62485           PARP(90) = 0.189
62486         ELSEIF (ITUNE.EQ.348) THEN
62487           PARP(82) = 1.89
62488           PARP(83) = 0.356
62489           PARP(84) = 0.415
62490           PARP(90) = 0.182
62491         ELSEIF (ITUNE.EQ.349) THEN
62492           PARP(82) = 1.86
62493           PARP(83) = 0.356
62494           PARP(84) = 0.588
62495           PARP(90) = 0.177
62496         ENDIF
62497         
62498 C...Primordial kT
62499         PARP(91) = 2.0D0
62500         PARP(93) = 5D0
62501         IF (ITUNE.GE.340) THEN
62502           PARP(93) = 10D0
62503         ENDIF
62504         IF (ITUNE.GE.345) THEN
62505           PARP(91) = 2.0
62506         ENDIF
62507 
62508 C...ISR
62509         IF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
62510           MSTP(64) = 2
62511           PARP(62) = 1.13
62512           PARP(64) = 0.68
62513           PARP(67) = 1.0
62514         ELSE IF (ITUNE.EQ.347) THEN
62515           MSTP(64) = 2
62516           PARP(62) = 0.946
62517           PARP(64) = 1.032
62518           PARP(67) = 1.0
62519         ELSE IF (ITUNE.EQ.348) THEN
62520           MSTP(64) = 2
62521           PARP(62) = 0.312
62522           PARP(64) = 0.939
62523           PARP(67) = 1.0
62524         ELSE IF (ITUNE.EQ.349) THEN
62525           MSTP(64) = 2
62526           PARP(62) = 1.246
62527           PARP(64) = 0.771
62528           PARP(67) = 1.0
62529         ELSE IF (ITUNE.GE.340) THEN
62530           PARP(62) = 1.025
62531         ENDIF
62532 
62533 C...FSR off ISR (LambdaQCD) for A*ET2B tunes
62534         IF (ITUNE.GE.345) THEN
62535           MSTP(72) = 2
62536           PARP(72) = 0.527
62537           IF (ITUNE.EQ.348) THEN
62538             PARP(72) = 0.537
62539           ENDIF
62540         ENDIF
62541 
62542         IF (M13.GE.1) THEN
62543           IF (ITUNE.LT.340) THEN
62544             CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62545           ELSEIF (ITUNE.EQ.340) THEN
62546             CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
62547           ELSEIF (ITUNE.EQ.341) THEN
62548             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62549             WRITE(M11,5030) CH60
62550             CH60='Z1 variation tuned by R. D. Field (CMS)'
62551           ELSEIF (ITUNE.EQ.342) THEN
62552             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62553             WRITE(M11,5030) CH60
62554             CH60='Z1 variation retuned by R. D. Field (CMS)'
62555             WRITE(M11,5030) CH60
62556             CH60='Z1-LEP variation retuned by Professor / P. Skands'
62557           ELSEIF (ITUNE.EQ.343) THEN
62558             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62559             WRITE(M11,5030) CH60
62560             CH60='Z2 variation retuned by R. D. Field (CMS)'
62561           ELSEIF (ITUNE.EQ.344) THEN
62562             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62563             WRITE(M11,5030) CH60
62564             CH60='Z2 variation retuned by R. D. Field (CMS)'
62565             WRITE(M11,5030) CH60
62566             CH60='Z2-LEP variation retuned by Professor / P. Skands'
62567           ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
62568             CH60='A*T2B tunes by ATLAS, ATL-PHYS-PUB-2011-009'
62569           ELSEIF (ITUNE.GE.347) THEN
62570             CH60='A*T2B-NLO tunes by ATLAS, ATL-PHYS-PUB-2011-014'
62571             WRITE(M11,5030) CH60
62572             CH60='Warning: NLO PDFs are NOT recommended!'
62573           ENDIF
62574           WRITE(M11,5030) CH60
62575           CH60='Physics Model: '//
62576      &         'T. Sjostrand & P. Skands, hep-ph/0408302'
62577           WRITE(M11,5030) CH60
62578           CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
62579           WRITE(M11,5030) CH60
62580 
62581 C...Output
62582           WRITE(M11,5030) ' '
62583           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62584           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62585           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
62586           IF (MSTP(3).EQ.1) THEN
62587             WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
62588             WRITE(M11,6110) 112, PARU(112), CHPARU(112)
62589             WRITE(M11,5050)   1, PARP(1)  , CHPARP(  1)
62590           ENDIF
62591           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62592           IF (MSTP(3).EQ.1) THEN
62593             WRITE(M11,5050)  72, PARP(72) , CHPARP( 72)
62594             WRITE(M11,5050)  61, PARP(61) , CHPARP( 61)
62595           ENDIF
62596           WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62597           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62598           WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62599           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62600           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62601           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62602           WRITE(M11,5030) CH60
62603           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62604           IF (MSTP(70).EQ.0) THEN
62605             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62606           ENDIF
62607           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62608           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62609           WRITE(M11,5050) 72, PARP(72), CHPARP(72)
62610           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62611           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62612           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62613           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62614           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62615           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62616           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62617           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62618           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62619           IF (MSTP(82).GE.2) THEN
62620             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
62621             IF (PARP(87).GE.0D0) 
62622      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
62623           ENDIF
62624           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62625           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62626           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62627           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62628           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62629           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62630           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62631           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62632           IF (MSTP(95).GE.1) THEN
62633             WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62634             IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62635           ENDIF
62636 
62637         ENDIF
62638 
62639 C=======================================================================
62640 C...S0, S1, S2, S0A, NOCR, Rap,
62641 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
62642 C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
62643 C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
62644 C...Perugia 2011 (incl variations)
62645 C...Schulz-Skands tunes
62646       ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
62647      &    .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
62648      &    .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
62649      &    .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
62650      &    .OR.(ITUNE.GE.350.AND.ITUNE.LE.389)) THEN
62651         IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62652         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62653           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62654      &        ' with tune.')
62655         ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND.
62656      &         ITUNE.NE.334.AND.
62657      &        (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
62658      &        THEN
62659           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62660      &        ' with tune.')
62661         ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
62662      &         (MSTP(181).LE.5.OR.
62663      &         (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
62664      &        THEN
62665           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62666      &        ' with tune.')
62667         ENDIF
62668  
62669 C...Use 327 as base tune for 350-359 and 370-379 (Perugia 2011 and 2012)
62670         ITUNSV = ITUNE
62671         IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
62672         IF (ITUNE.GE.370.AND.ITUNE.LE.389) ITUNE = 327
62673 C...Use 320 as base tune for 360+ (Schulz-Skands)
62674         IF (ITUNE.GE.360) ITUNE = 320
62675 
62676 C...HAD: Use Professor's LEP pars if ITUNE >= 310
62677 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
62678         IF (ITUNE.LT.310) THEN
62679 C...# Old defaults
62680           MSTJ(11) = 4
62681 C...# Old default flavour parameters
62682           PARJ(1)  =   0.1
62683           PARJ(2)  =   0.3  
62684           PARJ(3)  =   0.40 
62685           PARJ(4)  =   0.05 
62686           PARJ(11) =   0.5  
62687           PARJ(12) =   0.6 
62688           PARJ(21) = 0.36
62689           PARJ(41) = 0.30
62690           PARJ(42) = 0.58
62691           PARJ(46) = 1.0
62692           PARJ(82) = 1.0
62693           
62694         ELSEIF (ITUNE.GE.310) THEN
62695 C...# Tuned flavour parameters:
62696           PARJ(1)  = 0.073
62697           PARJ(2)  = 0.2
62698           PARJ(3)  = 0.94
62699           PARJ(4)  = 0.032
62700           PARJ(11) = 0.31
62701           PARJ(12) = 0.4
62702           PARJ(13) = 0.54
62703           PARJ(25) = 0.63
62704           PARJ(26) = 0.12
62705 C...# Always use pT-ordered shower:
62706           MSTJ(41) = 12
62707 C...# Switch on Bowler:
62708           MSTJ(11) = 5
62709 C...# Fragmentation
62710           PARJ(21) = 0.313
62711           PARJ(41) = 0.49
62712           PARJ(42) = 1.2
62713           PARJ(47) = 1.0
62714           PARJ(81) = 0.257
62715           PARJ(82) = 0.8
62716 
62717 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
62718           IF (ITUNE.EQ.321) PARJ(21) = 0.34D0
62719           IF (ITUNE.EQ.322) PARJ(21) = 0.28D0
62720 
62721 C...HAD: P-2010 and P-K use different strangeness parameters 
62722 C...     indicated by LEP and RHIC yields.
62723 C...(only 5% different from Professor values, so should be within acceptable
62724 C...theoretical uncertainty range)
62725 C...(No attempt made to retune other flavor parameters post facto)
62726           IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62727             PARJ( 1) = 0.08D0
62728             PARJ( 2) = 0.21D0
62729             PARJ( 4) = 0.04D0
62730             PARJ(11) = 0.35D0
62731             PARJ(12) = 0.35D0
62732             PARJ(21) = 0.36D0
62733             PARJ(41) = 0.35D0
62734             PARJ(42) = 0.90D0
62735             PARJ(81) = 0.26D0
62736             PARJ(82) = 1.0D0
62737           ENDIF 
62738         ENDIF
62739  
62740 C...Remove middle digit now for Professor variants, since identical pars
62741         ITUNEB=ITUNE
62742         IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
62743           ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
62744         ENDIF
62745  
62746 C...PDFs: all use CTEQ5L as starting point
62747         MSTP(52) = 1
62748         MSTP(51) = 7
62749         IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN
62750 C...MRST LO* for 325 and 335
62751           MSTP(52) = 2
62752           MSTP(51) = 20650
62753         ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
62754 C...CTEQ6L1 for 326 and 336
62755           MSTP(52) = 2
62756           MSTP(51) = 10042
62757         ELSEIF (ITUNE.EQ.339) THEN
62758 C...MRST LO** for 339
62759           MSTP(52) = 2
62760           MSTP(51) = 20651
62761         ENDIF
62762  
62763 C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
62764         MSTP(3) = 2
62765         IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62766           MSTP(3)   = 1
62767 C...Hardcode CTEQ5L values for ME and ISR
62768           MSTU(112) = 4
62769           PARU(112) = 0.192D0
62770           PARP(61)  = 0.192D0
62771           PARP( 1)  = 0.192D0
62772 C...but use LEP value also for non-res FSR
62773           PARP(72)  = 0.260D0
62774         ENDIF
62775 
62776 C...ISR: use Lambda_MSbar with default scale for S0(A)
62777         MSTP(64) = 2
62778         PARP(64) = 1D0
62779         IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334
62780      &       .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN
62781 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
62782           MSTP(64) = 3
62783           PARP(64) = 1D0
62784         ELSEIF (ITUNE.EQ.321) THEN
62785 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
62786           MSTP(64) = 3
62787           PARP(64) = 0.25D0
62788         ELSEIF (ITUNE.EQ.322) THEN
62789 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
62790           MSTP(64) = 2
62791           PARP(64) = 2D0
62792         ELSEIF (ITUNE.EQ.325) THEN
62793 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
62794           MSTP(64) = 3
62795           PARP(64) = 2D0
62796         ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
62797      &         ITUNE.EQ.339) THEN
62798 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
62799           MSTP(64) = 2
62800           PARP(64) = 1.3D0
62801           IF (ITUNE.EQ.335) PARP(64) = 0.92D0
62802           IF (ITUNE.EQ.336) PARP(64) = 0.89D0
62803           IF (ITUNE.EQ.339) PARP(64) = 0.97D0
62804         ENDIF
62805  
62806 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
62807         MSTP(67) = 2
62808         PARP(67) = 4D0
62809 C...Perugia tunes have stronger suppression, except HARD
62810         IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62811           PARP(67) = 1D0
62812           IF (ITUNE.EQ.321) PARP(67) = 4D0
62813           IF (ITUNE.EQ.322) PARP(67) = 0.25D0
62814         ENDIF
62815  
62816 C...ISR IR cutoff type and FSR off ISR setting:
62817 C...Smooth ISR, low FSR-off-ISR
62818         MSTP(70) = 2
62819         MSTP(72) = 0
62820         IF (ITUNEB.EQ.301) THEN
62821 C...S1, S1-Pro: sharp ISR, high FSR
62822           MSTP(70) = 0
62823           MSTP(72) = 1
62824         ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
62825      &        .OR.ITUNE.EQ.325) THEN
62826 C...Perugia default is smooth ISR, high FSR-off-ISR
62827           MSTP(70) = 2
62828           MSTP(72) = 1
62829         ELSEIF (ITUNE.EQ.321) THEN
62830 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
62831           MSTP(70) = 0
62832           PARP(62) = 1.25D0
62833           MSTP(72) = 1
62834         ELSEIF (ITUNE.EQ.322) THEN
62835 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
62836           MSTP(70) = 1
62837           PARP(81) = 1.5D0
62838           MSTP(72) = 0
62839         ELSEIF (ITUNE.EQ.323) THEN
62840 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62841           MSTP(70) = 0
62842           PARP(62) = 1.25D0
62843           MSTP(72) = 2
62844         ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62845 C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62846           MSTP(70) = 2
62847           MSTP(72) = 2
62848         ENDIF
62849  
62850 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated 
62851 C...by Professor tunes (with HARD and SOFT variations)
62852         PARP(71) = 4D0
62853         IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN 
62854           PARP(71) = 2D0
62855           IF (ITUNE.EQ.321) PARP(71) = 4D0
62856           IF (ITUNE.EQ.322) PARP(71) = 1D0
62857         ENDIF
62858         IF (ITUNE.EQ.329) PARP(71) = 2D0
62859         IF (ITUNE.EQ.335) PARP(71) = 1.29D0
62860         IF (ITUNE.EQ.336) PARP(71) = 1.72D0
62861         IF (ITUNE.EQ.339) PARP(71) = 1.20D0
62862 
62863 C...FSR: Lambda_FSR scale (only if not using professor)
62864         IF (ITUNE.LT.310) PARJ(81) = 0.23D0
62865         IF (ITUNE.EQ.321) PARJ(81) = 0.30D0
62866         IF (ITUNE.EQ.322) PARJ(81) = 0.20D0
62867 
62868 C...K-factor : only 328 uses a K-factor on the UE cross sections
62869         MSTP(33) = 0
62870         IF (ITUNE.EQ.328) THEN
62871           MSTP(33) = 10
62872           PARP(32) = 1.5
62873         ENDIF
62874 C...UE on, new model
62875         MSTP(81) = 21
62876  
62877 C...UE: hadron-hadron overlap profile (expOfPow for all)
62878         MSTP(82) = 5
62879 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
62880         PARP(83) = 1.6D0
62881         IF (ITUNEB.EQ.301) PARP(83) = 1.4D0
62882         IF (ITUNEB.EQ.302) PARP(83) = 1.2D0
62883 C...NOCR variants have very smooth distributions
62884         IF (ITUNEB.EQ.304) PARP(83) = 1.8D0
62885         IF (ITUNEB.EQ.305) PARP(83) = 2.0D0
62886         IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62887 C...Perugia variants have slightly smoother profiles by default
62888 C...(to compensate for more tail by added radiation)
62889 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
62890           PARP(83) = 1.7D0
62891           IF (ITUNE.EQ.322) PARP(83) = 1.5D0
62892           IF (ITUNE.EQ.327) PARP(83) = 1.5D0
62893           IF (ITUNE.EQ.328) PARP(83) = 1.5D0
62894 C...NOCR variants have smoother mass profiles
62895           IF (ITUNE.EQ.324) PARP(83) = 1.8D0
62896           IF (ITUNE.EQ.334) PARP(83) = 1.8D0
62897         ENDIF
62898 C...Professor-pT0 also has very smooth distribution
62899         IF (ITUNE.EQ.329) PARP(83) = 1.8
62900         IF (ITUNE.EQ.335) PARP(83) = 1.68
62901         IF (ITUNE.EQ.336) PARP(83) = 1.72
62902         IF (ITUNE.EQ.339) PARP(83) = 1.67
62903 
62904 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
62905         PARP(82) = 1.85D0
62906         IF (ITUNEB.EQ.301) PARP(82) = 2.1D0
62907         IF (ITUNEB.EQ.302) PARP(82) = 1.9D0
62908         IF (ITUNEB.EQ.304) PARP(82) = 2.05D0
62909         IF (ITUNEB.EQ.305) PARP(82) = 1.9D0
62910         IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62911 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
62912 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
62913 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
62914 C...slightly higher, due to increased activity.
62915           PARP(82) = 2.0D0
62916           IF (ITUNE.EQ.321) PARP(82) = 2.3D0
62917           IF (ITUNE.EQ.322) PARP(82) = 1.9D0
62918           IF (ITUNE.EQ.323) PARP(82) = 2.2D0
62919           IF (ITUNE.EQ.324) PARP(82) = 1.95D0
62920           IF (ITUNE.EQ.325) PARP(82) = 2.2D0
62921           IF (ITUNE.EQ.326) PARP(82) = 1.95D0
62922           IF (ITUNE.EQ.327) PARP(82) = 2.05D0
62923           IF (ITUNE.EQ.328) PARP(82) = 2.45D0
62924           IF (ITUNE.EQ.334) PARP(82) = 2.15D0
62925         ENDIF
62926 C...Professor-pT0 maintains low pT0 vaue
62927         IF (ITUNE.EQ.329) PARP(82) = 1.85D0
62928         IF (ITUNE.EQ.335) PARP(82) = 2.10D0
62929         IF (ITUNE.EQ.336) PARP(82) = 1.83D0
62930         IF (ITUNE.EQ.339) PARP(82) = 2.28D0
62931 
62932 C...UE: IR cutoff reference energy and default energy scaling pace
62933         PARP(89) = 1800D0
62934         PARP(90) = 0.16D0
62935 C...S0A, S0A-Pro have tune A energy scaling
62936         IF (ITUNEB.EQ.303) PARP(90) = 0.25D0
62937         IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62938 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
62939           PARP(90) = 0.26
62940           IF (ITUNE.EQ.321) PARP(90) = 0.30D0
62941           IF (ITUNE.EQ.322) PARP(90) = 0.24D0
62942           IF (ITUNE.EQ.323) PARP(90) = 0.32D0
62943           IF (ITUNE.EQ.324) PARP(90) = 0.24D0
62944 C...LO* and CTEQ6L1 tunes have slower energy scaling
62945           IF (ITUNE.EQ.325) PARP(90) = 0.23D0
62946           IF (ITUNE.EQ.326) PARP(90) = 0.22D0
62947         ENDIF
62948 C...Professor-pT0 has intermediate scaling
62949         IF (ITUNE.EQ.329) PARP(90) = 0.22D0
62950         IF (ITUNE.EQ.335) PARP(90) = 0.20D0
62951         IF (ITUNE.EQ.336) PARP(90) = 0.20D0
62952         IF (ITUNE.EQ.339) PARP(90) = 0.21D0
62953 
62954 C...BR: MPI initiator color connections rap-ordered by default
62955 C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
62956         MSTP(89) = 1
62957         IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89) = 2
62958         IF (ITUNE.EQ.322) MSTP(89) = 0
62959         IF (ITUNE.EQ.327) MSTP(89) = 0
62960         IF (ITUNE.EQ.328) MSTP(89) = 0
62961  
62962 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
62963         PARP(80) = 0.01D0
62964         IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN
62965 C...Perugia tunes have more beam blowup by default
62966           PARP(80) = 0.05D0
62967           IF (ITUNE.EQ.321) PARP(80) = 0.01
62968           IF (ITUNE.EQ.323) PARP(80) = 0.03
62969           IF (ITUNE.EQ.324) PARP(80) = 0.01
62970           IF (ITUNE.EQ.327) PARP(80) = 0.1
62971           IF (ITUNE.EQ.328) PARP(80) = 0.1
62972         ENDIF
62973  
62974 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
62975         MSTP(88) = 0
62976         PARP(79) = 2D0
62977         IF (ITUNEB.EQ.304) PARP(79) = 3D0
62978         IF (ITUNE.EQ.329) PARP(79) = 1.18
62979         IF (ITUNE.EQ.335) PARP(79) = 1.11
62980         IF (ITUNE.EQ.336) PARP(79) = 1.10
62981         IF (ITUNE.EQ.339) PARP(79) = 3.69
62982 
62983 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
62984         MSTP(91) = 1
62985         PARP(91) = 2D0
62986         PARP(93) = 10D0
62987 C...Perugia-HARD only uses 1.0 GeV
62988         IF (ITUNE.EQ.321) PARP(91) = 1.0D0
62989 C...Perugia-3 only uses 1.5 GeV
62990         IF (ITUNE.EQ.323) PARP(91) = 1.5D0
62991 C...Professor-pT0 uses 7-GeV cutoff
62992         IF (ITUNE.EQ.329) PARP(93) = 7.0
62993         IF (ITUNE.EQ.335) THEN
62994           PARP(91) = 2.15
62995           PARP(93) = 6.79
62996         ELSEIF (ITUNE.EQ.336) THEN
62997           PARP(91) = 1.85
62998           PARP(93) = 6.86
62999         ELSEIF (ITUNE.EQ.339) THEN
63000           PARP(91) = 2.11
63001           PARP(93) = 5.08
63002         ENDIF
63003 
63004 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
63005         MSTP(95) = 6
63006 C...S1, S1-Pro: use S1
63007         IF (ITUNEB.EQ.301) MSTP(95) = 2
63008 C...S2, S2-Pro: use S2
63009         IF (ITUNEB.EQ.302) MSTP(95) = 4
63010 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
63011         IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR.
63012      &       ITUNE.EQ.334) MSTP(95) = 0
63013 C..."Old" and "Old"-Pro: use old CR
63014         IF (ITUNEB.EQ.305) MSTP(95) = 1
63015 C...Perugia 2010 and K use Paquis model
63016         IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95) = 8
63017  
63018 C...FSI: CR strength and high-pT dampening, default is S0
63019         PARP(77) = 0D0
63020         IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
63021           PARP(78) = 0.2D0
63022           IF (ITUNEB.EQ.301) PARP(78) = 0.35D0
63023           IF (ITUNEB.EQ.302) PARP(78) = 0.15D0
63024           IF (ITUNEB.EQ.304) PARP(78) = 0.0D0
63025           IF (ITUNEB.EQ.305) PARP(78) = 1.0D0
63026           IF (ITUNE.EQ.329) PARP(78) = 0.17D0
63027           IF (ITUNE.EQ.335) PARP(78) = 0.14D0
63028           IF (ITUNE.EQ.336) PARP(78) = 0.17D0
63029           IF (ITUNE.EQ.339) PARP(78) = 0.13D0
63030         ELSE
63031 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
63032           PARP(78) = 0.33
63033           PARP(77) = 0.9D0
63034           IF (ITUNE.EQ.321) THEN
63035 C...HARD has HIGH amount of CR
63036             PARP(78) = 0.37D0
63037             PARP(77) = 0.4D0
63038           ELSEIF (ITUNE.EQ.322) THEN
63039 C...SOFT has LOW amount of CR
63040             PARP(78) = 0.15D0
63041             PARP(77) = 0.5D0
63042           ELSEIF (ITUNE.EQ.323) THEN
63043 C...Scaling variant appears to need slightly more than default
63044             PARP(78) = 0.35D0
63045             PARP(77) = 0.6D0
63046           ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN
63047 C...NOCR has no CR
63048             PARP(78) = 0D0
63049             PARP(77) = 0D0
63050           ELSEIF (ITUNE.EQ.327) THEN
63051 C...2010
63052             PARP(78) = 0.035D0
63053             PARP(77) = 1D0
63054           ELSEIF (ITUNE.EQ.328) THEN
63055 C...K
63056             PARP(78) = 0.033D0
63057             PARP(77) = 1D0
63058           ENDIF
63059         ENDIF
63060  
63061 C================
63062 C...Perugia 2011 and 2012 tunes 
63063 C...(written as modifications on top of Perugia 2010)
63064 C================
63065         IF ( (ITUNSV.GE.350.AND.ITUNSV.LE.359) 
63066      &       .OR.(ITUNSV.GE.370.AND.ITUNSV.LE.389) ) THEN
63067           ITUNE = ITUNSV
63068 C...  Scale setting for matching applications.
63069 C...  Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
63070 C...  (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
63071           MSTP(64) = 2
63072           MSTU(112) = 5
63073 C...  This sets the Lambda scale for ISR, IFSR, and FSR
63074           PARP(61) = 0.26D0
63075           PARP(72) = 0.26D0
63076           PARJ(81) = 0.26D0
63077 C...  This sets the Lambda scale for QCD hard interactions (important for the 
63078 C...  UE dijet cross sections. Here we still use an MSbar value, rather than 
63079 C...  a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
63080 C...  value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
63081           PARP(1) = 0.16D0
63082           PARU(112) = 0.16D0
63083 C...  For matching applications, PARP(71) and PARP(67) = 1
63084           PARP(67) = 1D0
63085           PARP(71) = 1D0
63086 C...  Primordial kT: only use 1 GeV
63087           MSTP(91) = 1
63088           PARP(91) = 1D0
63089 C...  ADDITIONAL LESSONS WRT PERUGIA 2010
63090 C...  ALICE taught us: need less baryon transport than SOFT
63091           MSTP(89) = 0
63092           PARP(80) = 0.015
63093 C...  Small adjustments at LEP (slightly softer frag functions, esp for baryons)
63094           PARJ(21) = 0.33
63095           PARJ(41) = 0.35
63096           PARJ(42) = 0.8
63097           PARJ(45) = 0.55
63098 C...  Increase Lambda/K ratio and other strange baryon yields 
63099           PARJ(1) = 0.087D0
63100           PARJ(3) = 0.95D0
63101           PARJ(4) = 0.043D0
63102           PARJ(6) = 1.0D0
63103           PARJ(7) = 1.0D0
63104 C...  Also reduce total strangeness yield a bit, with higher K*/K
63105           PARJ(2) = 0.19D0
63106           PARJ(12) = 0.40D0
63107 C...  Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
63108           MSTP(70) = 0
63109           MSTP(72) = 2
63110           PARP(62) = 1.5D0
63111 C...  Holger taught us a smoother proton is preferred at high energies
63112 C...  Just use a simple Gaussian 
63113           MSTP(82) = 3
63114 C...  Scaling of pt0 cutoff
63115           PARP(90) = 0.265
63116 C...  Now retune pT0 to give right UE activity.
63117 C...  Low CR strength indicated by LHC tunes 
63118 C...  (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
63119           PARP(78) = 0.036D0
63120 C...  Choose 7 TeV as new reference scale
63121           PARP(89) = 7000.0D0
63122           PARP(82) = 2.93D0          
63123 C================
63124 C...  P2011 Variations
63125 C================
63126           IF (ITUNE.EQ.351) THEN
63127 C...  radHi: high Lambda scale for ISR, IFSR, and FSR
63128 C...  ( ca 10% more particles at LEP after retune )
63129             PARP(61) = 0.52D0
63130             PARP(72) = 0.52D0
63131             PARJ(81) = 0.52D0
63132 C...  Retune cutoff scales to compensate partially
63133 C...  (though higher cutoff causes faster multiplicity drop at low energies)
63134             PARP(62) = 1.75D0
63135             PARJ(82) = 1.75D0
63136             PARP(82) = 3.00D0
63137 C...  Needs faster cutoff scaling than nominal variant for same <Nch> scaling
63138 C...  (since more radiation otherwise generates faster mult growth)
63139             PARP(90) = 0.28  
63140           ELSEIF (ITUNE.EQ.352) THEN
63141 C...  radLo: low Lambda scale for ISR, IFSR, and FSR
63142 C...  ( ca 10% less particles at LEP after retune )
63143             PARP(61) = 0.13D0
63144             PARP(72) = 0.13D0
63145             PARJ(81) = 0.13D0
63146 C...  Retune cutoff scales to compensate partially
63147             PARP(62) = 1.00D0
63148             PARJ(82) = 0.75D0
63149             PARP(82) = 2.95D0 
63150 C...  Needs slower cutoff scaling than nominal variant for same <Nch> scaling
63151 C...  (since less radiation otherwise generates slower mult growth)
63152             PARP(90) = 0.24
63153           ELSEIF (ITUNE.EQ.353) THEN
63154 C...  mpiHi: high Lambda scale for MPI
63155             PARP(1) = 0.26D0
63156             PARU(112) = 0.26D0
63157             PARP(82) = 3.35D0
63158             PARP(90) = 0.26D0
63159           ELSEIF (ITUNE.EQ.354) THEN
63160             MSTP(95) = 0
63161             PARP(82) = 3.05D0
63162           ELSEIF (ITUNE.EQ.355) THEN
63163 C...  LO**
63164             MSTP(52) = 2
63165             MSTP(51) = 20651
63166             PARP(62) = 1.5D0
63167 C...  Compensate for higher <pT> with less CR
63168             PARP(78) = 0.034
63169             PARP(82) = 3.40D0 
63170 C...  Need slower energy scaling than CTEQ5L
63171             PARP(90) = 0.23D0 
63172           ELSEIF (ITUNE.EQ.356) THEN
63173 C...  CTEQ6L1
63174             MSTP(52) = 2
63175             MSTP(51) = 10042
63176             PARP(82) = 2.65D0
63177 C...  Need slower cutoff scaling than CTEQ5L
63178             PARP(90) = 0.22D0 
63179           ELSEIF (ITUNE.EQ.357) THEN
63180 C...  T16
63181             PARP(90) = 0.16
63182           ELSEIF (ITUNE.EQ.358) THEN
63183 C...  T32
63184             PARP(90) = 0.32
63185           ELSEIF (ITUNE.EQ.359) THEN
63186 C...  Tevatron
63187             PARP(89) = 1800D0
63188             PARP(90) = 0.28 
63189             PARP(82) = 2.10 
63190             PARP(78) = 0.05 
63191           ENDIF
63192           
63193 C================
63194 C...  Perugia 2012 Variations
63195 C================
63196           IF (ITUNE.GE.370) THEN
63197 C...  CTEQ6L1 Baseline
63198             MSTP(52) = 2
63199             MSTP(51) = 10042
63200             PARP(82) = 2.65D0
63201 C...  Needs slower cutoff scaling than CTEQ5L
63202             PARP(90) = 0.24D0 
63203 C...  Slightly lower CR strength than Perugia 2011
63204             PARP(78) = 0.035D0
63205 C...  Adjusted fragmentation parameters wrt 2011
63206             PARJ(1)  = 0.085D0
63207             PARJ(2)  = 0.2
63208             PARJ(3)  = 0.92
63209             PARJ(25) = 0.70
63210             PARJ(26) = 0.135
63211             PARJ(41) = 0.45
63212             PARJ(42) = 1.0
63213             PARJ(45) = 0.86
63214           ENDIF
63215 C... Variations
63216           IF (ITUNE.EQ.371) THEN
63217 C...  radHi: high Lambda scale for ISR, IFSR, and FSR
63218 C...  ( ca 10% more particles at LEP after retune )
63219             PARP(61) = 0.52D0
63220             PARP(72) = 0.52D0
63221             PARJ(81) = 0.52D0
63222 C...  Retune cutoff scales to compensate partially
63223 C...  (though higher cutoff causes faster multiplicity drop at low energies)
63224             PARP(62) = 1.75D0
63225             PARJ(82) = 1.75D0
63226             PARP(82) = 2.725D0
63227 C...  Needs faster cutoff scaling than nominal variant for same <Nch> scaling
63228 C...  (since more radiation otherwise generates faster mult growth)
63229             PARP(90) = 0.25
63230           ELSEIF (ITUNE.EQ.372) THEN
63231 C...  radLo: low Lambda scale for ISR, IFSR, and FSR
63232 C...  ( ca 10% less particles at LEP after retune )
63233             PARP(61) = 0.13D0
63234             PARP(72) = 0.13D0
63235             PARJ(81) = 0.13D0
63236 C...  Retune cutoff scales to compensate partially
63237             PARP(62) = 1.00D0
63238             PARJ(82) = 0.75D0
63239             PARP(82) = 2.6D0 
63240 C...  Needs slower cutoff scaling than nominal variant for same <Nch> scaling
63241 C...  (since less radiation otherwise generates slower mult growth)
63242             PARP(90) = 0.23
63243           ELSEIF (ITUNE.EQ.373) THEN
63244 C...  mpiHi: high Lambda scale for MPI
63245             PARP(1) = 0.26D0
63246             PARU(112) = 0.26D0
63247             PARP(82) = 3.0D0
63248             PARP(90) = 0.24D0
63249           ELSEIF (ITUNE.EQ.374) THEN
63250 C... LOCR : uses global CR model. Less extreme alternative to noCR. 
63251             MSTP(95) = 6
63252             PARP(78) = 0.25D0
63253             PARP(82) = 2.7D0
63254             PARP(83) = 1.50D0
63255             PARP(90) = 0.24
63256           ELSEIF (ITUNE.EQ.375) THEN
63257 C... NOCR : with higher pT0
63258             MSTP(95) = 0
63259             PARP(82) = 2.80D0
63260           ELSEIF (ITUNE.EQ.376) THEN
63261 C... hadF1 (harder frag function, smaller n.p. pT)
63262             PARJ(21) = 0.30
63263             PARJ(41) = 0.36
63264             PARJ(42) = 1.0
63265             PARJ(45) = 0.75
63266           ELSEIF (ITUNE.EQ.377) THEN
63267 C... hadF2 (softer frag function, larger n.p. pT)
63268             PARJ(21) = 0.36 
63269             PARJ(41) = 0.45
63270             PARJ(42) = 0.75
63271             PARJ(45) = 0.9
63272           ELSEIF (ITUNE.EQ.378) THEN
63273 C... MSTW08LO
63274             MSTP(52) = 2
63275             MSTP(51) = 21000
63276             PARP(82) = 2.9D0 
63277 C...Uses a large LambdaQCD MSbar value (close to CMW one)
63278 C...(Nominally, MSTW 2008 alphaS(mZ) = 0.139)
63279             PARP(1) = 0.26D0
63280             PARU(112) = 0.26D0
63281 C...Tentative (fast) energy scaling
63282             PARP(90) = 0.29
63283           ELSEIF (ITUNE.EQ.379) THEN
63284 C... MSTW LO**
63285             MSTP(52) = 2
63286             MSTP(51) = 20651
63287             PARP(62) = 1.5D0
63288 C... Use a smaller LambdaQCD MSbar than with CTEQ
63289             PARP(1) = 0.14D0
63290             PARU(112) = 0.14D0
63291 C...  Compensate for higher <pT> with less CR
63292             PARP(78) = 0.034
63293             PARP(82) = 3.25D0 
63294 C...Tentative scaling
63295             PARP(90) = 0.25
63296           ELSEIF (ITUNE.EQ.380) THEN
63297 C...  val0: remove artificial valence-domination of low-pT scatterings
63298 C...  slightly faster energy scaling of pT0 cutoff (slower mult growth)
63299             PARP(87)=0D0
63300             PARP(90)=0.245
63301           ELSEIF (ITUNE.EQ.381) THEN
63302 C...  ueHi: lower pT0 value, slower pT0 scaling
63303             PARP(82)=2.46D0   
63304             PARP(90)=0.23
63305           ELSEIF (ITUNE.EQ.382) THEN
63306 C...  ueLo: higher pT0 value, faster pT0 scaling
63307             PARP(82)=2.92D0
63308             PARP(90)=0.26
63309           ELSEIF (ITUNE.EQ.383) THEN
63310 C...  IBK: same as Perugia 2012, but with Innsbruck ee fragm parameters 
63311 C...  Different Lambdas
63312             MSTP(3)  =  1
63313 C...  Lund+Bowler scheme for HQ fragment. 
63314             MSTJ(11) = 5
63315 C...  old baryon model     
63316             MSTJ(12) = 2
63317 C...  2=PYSHOW  12=PYPTFS for gluon and photon emiss.
63318             MSTJ(41) = 12
63319 C...  Lambda_LLA  
63320             PARJ(81) = 0.261  
63321 C...  p_tmin cutoff (set by hand)             
63322             PARJ(82) = 0.90    
63323 C...  sigma_pt
63324             PARJ(21) = 0.329   
63325 C...  A of LSFF
63326             PARJ(41) = 0.425   
63327 C...  B of LSFF
63328             PARJ(42) = 1.65    
63329 C...  r_c
63330             PARJ(46) = 1.42    
63331 C...  r_b
63332             PARJ(47) = 0.975   
63333 C...  reset popcorn parameters 
63334             PARJ( 6) = 0.5
63335             PARJ( 7) = 0.5
63336 C...  V_u,d
63337             PARJ(11) = 0.549   
63338 C...  V_s
63339             PARJ(12) = 0.450   
63340 C...  V_c,b
63341             PARJ(13) = 0.500   
63342 C...  L=1 mesons rates
63343             PARJ(17) = 0.20    
63344             PARJ(14) = 0.12   
63345             PARJ(15) = 0.04   
63346             PARJ(16) = 0.12   
63347 C...  eta suppr.
63348             PARJ(25) = 1.000
63349 C...  eta-prime suppr.
63350             PARJ(26) = 0.245   
63351 C...  s/u
63352             PARJ( 2) = 0.268   
63353 C...  qq/q
63354             PARJ( 1) = 0.128   
63355 C...  su/du
63356             PARJ( 3) = 0.772   
63357 C...  (qq)_1
63358             PARJ( 4) = 0.05    
63359 C...  end-point baryon suppress.           
63360             PARJ(19) = 0.402   
63361 C...  reset a(Baryon)-a(Meson) parameter to default value
63362             PARJ(45) = 0.50
63363           ENDIF 
63364 C================
63365 C...Schulz-Skands 2011 tunes 
63366 C...(written as modifications on top of Perugia 0)
63367 C================
63368         ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
63369           ITUNE = ITUNSV
63370 
63371           IF (ITUNE.EQ.360) THEN
63372             PARP(78) = 0.40D0
63373             PARP(82) = 2.19D0
63374             PARP(83) = 1.45D0
63375             PARP(89) = 1800.0D0
63376             PARP(90) = 0.27D0
63377           ELSEIF (ITUNE.EQ.361) THEN
63378             PARP(78) = 0.20D0
63379             PARP(82) = 2.75D0
63380             PARP(83) = 1.73D0
63381             PARP(89) = 7000.0D0
63382           ELSEIF (ITUNE.EQ.362) THEN
63383             PARP(78) = 0.31D0
63384             PARP(82) = 1.97D0
63385             PARP(83) = 1.98D0
63386             PARP(89) = 1960.0D0
63387           ELSEIF (ITUNE.EQ.363) THEN
63388             PARP(78) = 0.35D0
63389             PARP(82) = 1.91D0
63390             PARP(83) = 2.02D0
63391             PARP(89) = 1800.0D0
63392           ELSEIF (ITUNE.EQ.364) THEN
63393             PARP(78) = 0.33D0
63394             PARP(82) = 1.69D0
63395             PARP(83) = 1.92D0
63396             PARP(89) = 900.0D0
63397           ELSEIF (ITUNE.EQ.365) THEN
63398             PARP(78) = 0.47D0
63399             PARP(82) = 1.61D0
63400             PARP(83) = 1.50D0
63401             PARP(89) = 630.0D0
63402           ENDIF
63403 
63404         ENDIF
63405         
63406 C...Switch off trial joinings
63407         MSTP(96) = 0
63408  
63409 C...S0 (300), S0A (303)
63410         IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
63411           IF (M13.GE.1) THEN
63412             CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63413             WRITE(M11,5030) CH60
63414             CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
63415             WRITE(M11,5030) CH60
63416             CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63417             WRITE(M11,5030) CH60
63418             IF (ITUNE.GE.310) THEN
63419               CH60='LEP parameters tuned by Professor,'//
63420      &             ' hep-ph/0907.2973'
63421               WRITE(M11,5030) CH60
63422             ENDIF
63423           ENDIF
63424  
63425 C...S1 (301)
63426         ELSEIF(ITUNEB.EQ.301) THEN
63427           IF (M13.GE.1) THEN
63428             CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63429             WRITE(M11,5030) CH60
63430             CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63431             WRITE(M11,5030) CH60
63432             IF (ITUNE.GE.310) THEN
63433               CH60='LEP parameters tuned by Professor,'//
63434      &             ' hep-ph/0907.2973'
63435               WRITE(M11,5030) CH60
63436             ENDIF
63437           ENDIF
63438  
63439 C...S2 (302)
63440         ELSEIF(ITUNEB.EQ.302) THEN
63441           IF (M13.GE.1) THEN
63442             CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63443             WRITE(M11,5030) CH60
63444             CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63445             WRITE(M11,5030) CH60
63446             IF (ITUNE.GE.310) THEN
63447               CH60='LEP parameters tuned by Professor,'//
63448      &             ' hep-ph/0907.2973'
63449               WRITE(M11,5030) CH60
63450             ENDIF
63451           ENDIF
63452  
63453 C...NOCR (304)
63454         ELSEIF(ITUNEB.EQ.304) THEN
63455           IF (M13.GE.1) THEN
63456             CH60='"best try" without colour reconnections'
63457             WRITE(M11,5030) CH60
63458             CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63459             WRITE(M11,5030) CH60
63460             CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63461             WRITE(M11,5030) CH60
63462             IF (ITUNE.GE.310) THEN
63463               CH60='LEP parameters tuned by Professor,'//
63464      &             ' hep-ph/0907.2973'
63465               WRITE(M11,5030) CH60
63466             ENDIF
63467           ENDIF
63468  
63469 C..."Lo FSR" retune (305)
63470         ELSEIF(ITUNEB.EQ.305) THEN
63471           IF (M13.GE.1) THEN
63472             CH60='"Lo FSR retune" with primitive colour reconnections'
63473             WRITE(M11,5030) CH60
63474             CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
63475             WRITE(M11,5030) CH60
63476             IF (ITUNE.GE.310) THEN
63477               CH60='LEP parameters tuned by Professor,'//
63478      &             ' hep-ph/0907.2973'
63479               WRITE(M11,5030) CH60
63480             ENDIF
63481           ENDIF
63482  
63483 C...Perugia Tunes (320-328 and 334)
63484         ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
63485           IF (M13.GE.1) THEN
63486             CH60='Tuned by P. Skands, hep-ph/1005.3457'
63487             WRITE(M11,5030) CH60
63488             CH60='Physics Model: '//
63489      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
63490             WRITE(M11,5030) CH60
63491             IF (ITUNE.LE.326) THEN
63492               CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63493               WRITE(M11,5030) CH60
63494               CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63495               WRITE(M11,5030) CH60
63496             ENDIF
63497             IF (ITUNE.EQ.325) THEN
63498               CH70='NB! This tune requires MRST LO* pdfs to be '//
63499      &            'externally linked'
63500               WRITE(M11,5035) CH70
63501             ELSEIF (ITUNE.EQ.326) THEN
63502               CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63503      &            'externally linked'
63504               WRITE(M11,5035) CH70
63505             ELSEIF (ITUNE.EQ.321) THEN
63506               CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
63507               WRITE(M11,5030) CH60
63508             ELSEIF (ITUNE.EQ.322) THEN
63509               CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
63510               WRITE(M11,5030) CH60
63511             ENDIF
63512           ENDIF
63513  
63514 C...Professor-pTO (329)
63515         ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
63516      &         ITUNE.EQ.339) THEN
63517           IF (M13.GE.1) THEN
63518             CH60='Tuned by Professor, hep-ph/0907.2973'
63519             WRITE(M11,5030) CH60 
63520             CH60='Physics Model: '//
63521      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
63522             WRITE(M11,5030) CH60
63523             CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63524             WRITE(M11,5030) CH60
63525           ENDIF
63526  
63527 C...Perugia 2011 Tunes (350-359)
63528         ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
63529           IF (M13.GE.1) THEN
63530             CH60='Tuned by P. Skands, hep-ph/1005.3457'
63531             WRITE(M11,5030) CH60
63532             CH60='Physics Model: '//
63533      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
63534             WRITE(M11,5030) CH60
63535             CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63536             WRITE(M11,5030) CH60
63537             IF (ITUNE.EQ.355) THEN
63538               CH70='NB! This tune requires MRST LO** pdfs to be '//
63539      &            'externally linked'
63540               WRITE(M11,5035) CH70
63541             ELSEIF (ITUNE.EQ.356) THEN
63542               CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63543      &            'externally linked'
63544               WRITE(M11,5035) CH70
63545             ENDIF
63546           ENDIF
63547 
63548 C...Schulz-Skands Tunes (360-365)
63549         ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
63550           IF (M13.GE.1) THEN
63551             CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
63552             WRITE(M11,5030) CH60
63553             CH60='Based on Perugia 0, hep-ph/1005.3457'
63554             WRITE(M11,5030) CH60
63555             CH60='Physics Model: '//
63556      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
63557             WRITE(M11,5030) CH60
63558             CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63559             WRITE(M11,5030) CH60
63560           ENDIF
63561  
63562 C...Perugia 2012 Tunes (370-389)
63563         ELSEIF(ITUNE.GE.370.AND.ITUNE.LE.389) THEN
63564           IF (M13.GE.1) THEN
63565             CH60='Tuned by P. Skands, hep-ph/1005.3457'
63566             WRITE(M11,5030) CH60
63567             IF (ITUNE.EQ.383) THEN
63568               CH60='with Innsbruck (IBK) ee fragmentation parameters'
63569               WRITE(M11,5030) CH60
63570             ENDIF
63571             CH60='Physics Model: '//
63572      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
63573             WRITE(M11,5030) CH60
63574             CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63575             WRITE(M11,5030) CH60
63576             IF (ITUNE.EQ.378) THEN
63577             ELSEIF (ITUNE.EQ.379) THEN
63578               CH70='NB! This tune requires MRST 2008 LO** pdfs to be '//
63579      &            'externally linked'
63580               WRITE(M11,5035) CH70
63581             ELSE 
63582               CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63583      &            'externally linked'
63584               WRITE(M11,5035) CH70
63585             ENDIF
63586           ENDIF
63587 
63588         ENDIF
63589  
63590 C...Output
63591         IF (M13.GE.1) THEN
63592           WRITE(M11,5030) ' '
63593           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63594           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63595           IF (MSTP(33).GE.10) THEN
63596             WRITE(M11,5050) 32, PARP(32), CHPARP(32)
63597           ENDIF
63598           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
63599           IF (MSTP(3).EQ.1) THEN
63600             WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
63601             WRITE(M11,6110) 112, PARU(112), CHPARU(112)
63602             WRITE(M11,5050)   1, PARP(1)  , CHPARP(  1)
63603           ENDIF
63604           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63605           IF (MSTP(3).EQ.1) THEN 
63606             WRITE(M11,5050)  72, PARP(72) , CHPARP( 72)
63607             WRITE(M11,5050)  61, PARP(61) , CHPARP( 61)
63608           ENDIF
63609           WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
63610           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63611           WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
63612           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63613           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63614           WRITE(M11,5030) CH60
63615           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63616           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63617           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63618           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63619           IF (MSTP(70).EQ.0) THEN
63620             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63621           ELSEIF (MSTP(70).EQ.1) THEN
63622             WRITE(M11,5050) 81, PARP(81), CHPARP(62)
63623             CH60='(Note: PARP(81) replaces PARP(62).)'
63624             WRITE(M11,5030) CH60
63625           ENDIF
63626           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63627           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63628           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63629           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63630           IF (MSTP(70).EQ.2) THEN
63631             CH60='(Note: PARP(82) replaces PARP(62).)'
63632             WRITE(M11,5030) CH60
63633           ENDIF
63634           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63635           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63636           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63637           IF (MSTP(82).EQ.5) THEN
63638             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63639           ELSEIF (MSTP(82).EQ.4) THEN
63640             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63641             WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63642           ENDIF
63643           IF (MSTP(82).GE.2) THEN
63644             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
63645             IF (PARP(87).GE.0D0) 
63646      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
63647           ENDIF
63648           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63649           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63650           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63651           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63652           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63653           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63654           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63655           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63656           IF (MSTP(95).GE.1) THEN
63657             WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63658             IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
63659           ENDIF
63660 
63661         ENDIF
63662  
63663 C=======================================================================
63664 C...Innsbruck tunes (provided by N. Firdous and G. Rudolph, Innsbruck)
63665 C...390-395
63666       ELSEIF (ITUNE.GE.390.AND.ITUNE.LE.395) THEN 
63667         IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
63668         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419))THEN
63669           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63670      &        ' with tune.')
63671         ENDIF
63672 
63673 C...  1) Set the IBK ee fragmentation parameters (March 2012)
63674 C...  Lund+Bowler scheme for HQ fragment. 
63675         MSTJ(11) = 5
63676 C...  old baryon model     
63677         MSTJ(12) = 2
63678 C...  2=PYSHOW  12=PYPTFS for gluon and photon emiss.
63679         MSTJ(41) = 12
63680 C...  Lambda_LLA  
63681         PARJ(81) = 0.261  
63682 C...  p_tmin cutoff (set by hand)             
63683         PARJ(82) = 0.90    
63684 C...  sigma_pt
63685         PARJ(21) = 0.329   
63686 C...  A of LSFF
63687         PARJ(41) = 0.425   
63688 C...  B of LSFF
63689         PARJ(42) = 1.65    
63690 C...  r_c
63691         PARJ(46) = 1.42    
63692 C...  r_b
63693         PARJ(47) = 0.975   
63694 C...  V_u,d
63695         PARJ(11) = 0.549   
63696 C...  V_s
63697         PARJ(12) = 0.450   
63698 C...  V_c,b
63699         PARJ(13) = 0.500   
63700 C...  L=1 mesons rates
63701         PARJ(17) = 0.20    
63702         PARJ(14) = 0.12   
63703         PARJ(15) = 0.04   
63704         PARJ(16) = 0.12   
63705 C...  eta suppr.
63706         PARJ(25) = 1.000
63707 C...  eta-prime suppr.
63708         PARJ(26) = 0.245   
63709 C...  s/u
63710         PARJ( 2) = 0.268   
63711 C...  qq/q
63712         PARJ( 1) = 0.128   
63713 C...  su/du
63714         PARJ( 3) = 0.772   
63715 C...  (qq)_1
63716         PARJ( 4) = 0.05    
63717 C...  end-point baryon suppress.           
63718         PARJ(19) = 0.402   
63719 C...  reset a(Baryon)-a(Meson) parameter to default value
63720         PARJ(45) = 0.50
63721 
63722 C...  2) Set the global IBK pp tune parameters        
63723 C...  Different Lambda_QCD    
63724         MSTP(  3) = 1
63725 C...  N_flavors = 5
63726         MSTU(112) = 5
63727 C...  MPI & BR master switch   
63728         MSTP( 81) = 21
63729 C...  alpha_s(Q**2) choice in ISR  (def=2)                  
63730         MSTP( 64) = 2
63731 C...  ISR regularisation (def=1)
63732         MSTP( 70) = 2
63733 C...  ptmax scale for rad betw ISR partons (def=1)
63734         MSTP( 72) = 2
63735 C...  MPI structure: matter overlap (def=4) 
63736         MSTP( 82) = 5
63737 C...  collapse of junction configur. (def=1) 
63738         MSTP( 88) = 0
63739 C...  CR: annealing model (def=1) 
63740         MSTP( 95) = 6 
63741 C...  Lam_QCD for ISR 
63742         PARP( 61) = 0.190
63743 C...  K-factor in alpha_s for ISR (def=1.) 
63744         PARP( 64) = 1.0
63745 C...  max.virt. scale factor for ISR  (def=4.)                  
63746         PARP( 67) = 1.0
63747 C...  max.virt. scale factor for FSR (def=4.) 
63748         PARP( 71) = 1.0
63749 C...  CR suppression for fast moving strings (def=0.)
63750         PARP( 77) = 0.90
63751 C...  PT0 reference Ecm (def=1800 GeV)
63752         PARP( 89) = 7000.0
63753 C...  beam remnant x enhancement  (def=2.)              
63754         PARP( 79) = 1.50
63755 C...  beam remnant breakup suppression (def=0.1)        
63756         PARP( 80) = 0.06
63757 C...  intrinsic kT width (def=2.0) 
63758         PARP( 91) = 2.0
63759 C...  intrinsic kT cutoff(def=5.0) 
63760         PARP( 93) = 10.0
63761 
63762 C...  3) Set the tune-specific IBK pp tune parameters
63763         IF (ITUNE.EQ.390) THEN
63764 C...  CTEQ5L          
63765           MSTP(51)=7  
63766           MSTP(52)=1
63767           PARP(82)=2.942
63768           PARP(90)=0.2450
63769           PARP(83)=1.817
63770           PARP(78)=0.433 
63771           PARP( 1)=0.163
63772           PARU(112)=0.163
63773           PARP(72)=0.531
63774         ELSEIF (ITUNE.EQ.391) THEN
63775 C...  CTEQ6LL
63776           MSTP(51)=10042
63777           MSTP(52)=2
63778           PARP(82)=2.625
63779           PARP(90)=0.2178
63780           PARP(83)=1.863
63781           PARP(78)=0.461 
63782           PARP( 1)=0.141
63783           PARU(112)=0.141 
63784           PARP(72)=0.475
63785         ELSEIF (ITUNE.EQ.392) THEN
63786 C...  MSTW08LO
63787           MSTP(51)=21000
63788           MSTP(52)=2
63789           PARP(82)=2.889
63790           PARP(90)=0.2832
63791           PARP(83)=1.785
63792           PARP(78)=0.478 
63793           PARP( 1)=0.199
63794           PARU(112)=0.199
63795           PARP(72)=0.657            
63796         ELSEIF (ITUNE.EQ.393) THEN
63797 C...  CTEQ66 NLO
63798           MSTP(51)=10550
63799           MSTP(52)=2
63800           PARP(82)=2.172
63801           PARP(90)=0.1818
63802           PARP(83)=1.939
63803           PARP(78)=0.513 
63804           PARP( 1)=0.173
63805           PARU(112)=0.173 
63806           PARP(72)=0.456
63807         ELSEIF (ITUNE.EQ.394) THEN
63808 C...  CT10 NLO
63809           MSTP(51)=10800
63810           MSTP(52)=2
63811           PARP(82)=2.090
63812           PARP(90)=0.1687
63813           PARP(83)=1.939
63814           PARP(78)=0.517 
63815           PARP( 1)=0.177 
63816           PARU(112)=0.177
63817           PARP(72)=0.463 
63818         ELSEIF (ITUNE.EQ.395) THEN
63819 C...  MSTW08NLO
63820           MSTP(51)=21100
63821           MSTP(52)=2
63822           PARP(82)=1.773
63823           PARP(90)=0.1780
63824           PARP(83)=1.882
63825           PARP(78)=0.590 
63826           PARP( 1)=0.161 
63827           PARU(112)=0.161
63828           PARP(72)=0.367 
63829         ELSEIF (ITUNE.EQ.396) THEN
63830 C...  MRST07LO* 
63831           MSTP(51)=20650
63832           MSTP(52)=2
63833           PARP(82)=2.619
63834           PARP(90)=0.2286
63835           PARP(83)=1.812
63836           PARP(78)=0.471 
63837           PARP( 1)=0.082 
63838           PARU(112)=0.082 
63839           PARP(72)=0.500
63840         ELSEIF (ITUNE.EQ.397) THEN
63841 C...  MRSTMCal (LO**)
63842           MSTP(51)=20651
63843           MSTP(52)=2
63844           PARP(82)=2.802
63845           PARP(90)=0.2220
63846           PARP(83)=1.821
63847           PARP(78)=0.441 
63848           PARP( 1)=0.080
63849           PARU(112)=0.080 
63850           PARP(72)=0.519
63851         ELSEIF (ITUNE.EQ.398) THEN
63852 C...CT09MC2 
63853           MSTP(51)=10772
63854           MSTP(52)=2
63855           PARP(82)=2.355
63856           PARP(90)=0.2062
63857           PARP(83)=1.893
63858           PARP(78)=0.509 
63859           PARP( 1)=0.058 
63860           PARU(112)=0.058 
63861           PARP(72)=0.401
63862         ENDIF
63863 
63864 C...Output
63865         IF (M13.GE.1) THEN
63866           CH60='Tune provided by N. Firdous & G. Rudolph (Innsbruck)'
63867           WRITE(M11,5030) CH60
63868           CH60='Physics Model: '//
63869      &         'T. Sjostrand & P. Skands, hep-ph/0408302'
63870           WRITE(M11,5030) CH60
63871           CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63872           WRITE(M11,5030) CH60
63873           IF (ITUNE.GE.391) THEN
63874             CH70='NB ! This tune requires LHAPDF to be '//
63875      &           'externally linked'
63876             WRITE(M11,5035) CH70
63877           ENDIF
63878           WRITE(M11,5030) ' '
63879           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63880           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63881           IF (MSTP(33).GE.10) THEN
63882             WRITE(M11,5050) 32, PARP(32), CHPARP(32)
63883           ENDIF
63884           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
63885           IF (MSTP(3).EQ.1) THEN
63886             WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
63887             WRITE(M11,6110) 112, PARU(112), CHPARU(112)
63888             WRITE(M11,5050)   1, PARP(1)  , CHPARP(  1)
63889           ENDIF
63890           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63891           IF (MSTP(3).EQ.1) THEN 
63892             WRITE(M11,5050)  72, PARP(72) , CHPARP( 72)
63893             WRITE(M11,5050)  61, PARP(61) , CHPARP( 61)
63894           ENDIF
63895           WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
63896           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63897           WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
63898           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63899           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63900           WRITE(M11,5030) CH60
63901           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63902           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63903           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63904           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63905           IF (MSTP(70).EQ.0) THEN
63906             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63907           ELSEIF (MSTP(70).EQ.1) THEN
63908             WRITE(M11,5050) 81, PARP(81), CHPARP(62)
63909             CH60='(Note: PARP(81) replaces PARP(62).)'
63910             WRITE(M11,5030) CH60
63911           ENDIF
63912           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63913           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63914           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63915           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63916           IF (MSTP(70).EQ.2) THEN
63917             CH60='(Note: PARP(82) replaces PARP(62).)'
63918             WRITE(M11,5030) CH60
63919           ENDIF
63920           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63921           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63922           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63923           IF (MSTP(82).EQ.5) THEN
63924             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63925           ELSEIF (MSTP(82).EQ.4) THEN
63926             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63927             WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63928           ENDIF
63929           IF (MSTP(82).GE.2) THEN
63930             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
63931             IF (PARP(87).GE.0D0) 
63932      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
63933           ENDIF
63934           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63935           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63936           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63937           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63938           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63939           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63940           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63941           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63942           IF (MSTP(95).GE.1) THEN
63943             WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63944             IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
63945           ENDIF
63946 
63947         ENDIF
63948 C=======================================================================
63949 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
63950       ELSEIF (ITUNE.EQ.306) THEN
63951         IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
63952         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63953           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63954      &        ' with tune.')
63955         ENDIF
63956  
63957 C...PDFs
63958         MSTP(52) = 2
63959         MSTP(54) = 2
63960         MSTP(51) = 10042
63961         MSTP(53) = 10042
63962 C...ISR
63963 C        PARP(64) = 1D0
63964 C...UE on, new model.
63965         MSTP(81) = 21
63966 C...Energy scaling
63967         PARP(89) = 1800D0
63968         PARP(90) = 0.22D0
63969 C...Switch off trial joinings
63970         MSTP(96) = 0
63971 C...Primordial kT cutoff
63972  
63973         IF (M13.GE.1) THEN
63974           CH60='see presentations by A. Moraes (ATLAS),'
63975           WRITE(M11,5030) CH60
63976           CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63977           WRITE(M11,5030) CH60
63978           WRITE(M11,5030) ' '
63979           CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63980      &        'externally linked'
63981           WRITE(M11,5035) CH70
63982         ENDIF
63983 C...Smooth ISR, low FSR
63984         MSTP(70) = 2
63985         MSTP(72) = 0
63986 C...pT0
63987         PARP(82) = 1.9D0
63988 C...Transverse density profile.
63989         MSTP(82) = 4
63990         PARP(83) = 0.3D0
63991         PARP(84) = 0.5D0
63992 C...ISR & FSR in interactions after the first (default)
63993         MSTP(84) = 1
63994         MSTP(85) = 1
63995 C...No double-counting (default)
63996         MSTP(86) = 2
63997 C...Companion quark parent gluon (1-x) power
63998         MSTP(87) = 4
63999 C...Primordial kT compensation along chaings (default = 0 : uniform)
64000         MSTP(90) = 1
64001 C...Colour Reconnections
64002         MSTP(95) = 1
64003         PARP(78) = 0.2D0
64004 C...Lambda_FSR scale.
64005         PARJ(81) = 0.23D0
64006 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
64007         MSTP(89) = 1
64008         MSTP(88) = 0
64009 C   PARP(79) = 2D0
64010         PARP(80) = 0.01D0
64011 C...Peterson charm frag, and c and b hadr parameters
64012         MSTJ(11) = 3
64013         PARJ(54) = -0.07
64014         PARJ(55) = -0.006
64015 C...  Output
64016         IF (M13.GE.1) THEN
64017           WRITE(M11,5030) ' '
64018           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64019           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64020           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
64021           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64022           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64023           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64024           WRITE(M11,5030) CH60
64025           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
64026           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
64027           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64028           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64029           CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
64030           WRITE(M11,5030) CH60
64031           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64032           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64033           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64034           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64035           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64036           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64037           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64038           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64039           IF (MSTP(82).GE.2) THEN
64040             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
64041             IF (PARP(87).GE.0D0) 
64042      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
64043           ENDIF
64044           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
64045           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
64046           WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
64047           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
64048           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
64049           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64050           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
64051           WRITE(M11,5050) 78, PARP(78), CHPARP(78)
64052 
64053         ENDIF
64054  
64055 C=======================================================================
64056 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
64057 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
64058 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
64059       ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
64060      &      ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
64061      &      ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
64062         IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
64063           WRITE(M11,5010) ITUNE, CHNAME
64064           CH60='see R.D. Field, in hep-ph/0610012'
64065           WRITE(M11,5030) CH60
64066           CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64067           WRITE(M11,5030) CH60
64068           IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
64069             CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64070             WRITE(M11,5030) CH60
64071           ENDIF
64072         ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
64073           WRITE(M11,5010) ITUNE, CHNAME
64074           CH60='Tuned by Professor, hep-ph/0907.2973'
64075           WRITE(M11,5030) CH60
64076           CH60='Physics Model: '//
64077      &         'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64078           WRITE(M11,5030) CH60
64079         ENDIF
64080  
64081 C...Make sure we start from old default fragmentation parameters
64082         PARJ(81) = 0.29
64083         PARJ(82) = 1.0
64084  
64085 C...Use Professor's LEP pars if ITUNE >= 110
64086 C...(i.e., for A-Pro, DW-Pro etc)
64087         IF (ITUNE.LT.110) THEN
64088 C...# Old defaults
64089           MSTJ(11) = 4
64090           PARJ(1)  =   0.1
64091           PARJ(2)  =   0.3  
64092           PARJ(3)  =   0.40 
64093           PARJ(4)  =   0.05 
64094           PARJ(11) =   0.5  
64095           PARJ(12) =   0.6 
64096           PARJ(21) = 0.36
64097           PARJ(41) = 0.30
64098           PARJ(42) = 0.58
64099           PARJ(46) = 1.0
64100           PARJ(81) = 0.29
64101           PARJ(82) = 1.0
64102         ELSE
64103 C...# Tuned flavour parameters:
64104           PARJ(1)  = 0.073
64105           PARJ(2)  = 0.2
64106           PARJ(3)  = 0.94
64107           PARJ(4)  = 0.032
64108           PARJ(11) = 0.31
64109           PARJ(12) = 0.4
64110           PARJ(13) = 0.54
64111           PARJ(25) = 0.63
64112           PARJ(26) = 0.12
64113 C...# Switch on Bowler:
64114           MSTJ(11) = 5
64115 C...# Fragmentation
64116           PARJ(21) = 0.325
64117           PARJ(41) = 0.5
64118           PARJ(42) = 0.6
64119           PARJ(47) = 0.67
64120           PARJ(81) = 0.29
64121           PARJ(82) = 1.65
64122         ENDIF
64123  
64124 C...Remove middle digit now for Professor variants, since identical pars
64125         ITUNEB=ITUNE
64126         IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
64127           ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
64128         ENDIF
64129  
64130 C...Multiple interactions on, old framework
64131         MSTP(81) = 1
64132 C...Fast IR cutoff energy scaling by default
64133         PARP(89) = 1800D0
64134         PARP(90) = 0.25D0
64135 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
64136         MSTP(51) = 7
64137         MSTP(52) = 1
64138         IF (ITUNEB.EQ.105) THEN
64139           MSTP(51) = 10150
64140           MSTP(52) = 2
64141         ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
64142           MSTP(52) = 2
64143           MSTP(54) = 2
64144           MSTP(51) = 10042
64145           MSTP(53) = 10042
64146         ENDIF
64147 C...Double Gaussian matter distribution.
64148         MSTP(82) = 4
64149         PARP(83) = 0.5D0
64150         PARP(84) = 0.4D0
64151 C...FSR activity.
64152         PARP(71) = 4D0
64153 C...Fragmentation functions and c and b parameters
64154 C...(only if not using Professor)
64155         IF (ITUNE.LE.109) THEN
64156           MSTJ(11) = 4
64157           PARJ(54) = -0.05
64158           PARJ(55) = -0.005
64159         ENDIF
64160  
64161 C...Tune A and AW
64162         IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
64163 C...pT0.
64164           PARP(82) = 2.0D0
64165 c...String drawing almost completely minimizes string length.
64166           PARP(85) = 0.9D0
64167           PARP(86) = 0.95D0
64168 C...ISR cutoff, muR scale factor, and phase space size
64169           PARP(62) = 1D0
64170           PARP(64) = 1D0
64171           PARP(67) = 4D0
64172 C...Intrinsic kT, size, and max
64173           MSTP(91) = 1
64174           PARP(91) = 1D0
64175           PARP(93) = 5D0
64176 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
64177           IF (ITUNEB.EQ.101) THEN
64178             PARP(62) = 1.25D0
64179             PARP(64) = 0.2D0
64180             PARP(91) = 2.1D0
64181             PARP(92) = 15.0D0
64182           ENDIF
64183  
64184 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
64185         ELSEIF (ITUNEB.EQ.102) THEN
64186 C...pT0.
64187           PARP(82) = 1.9D0
64188 c...String drawing completely minimizes string length.
64189           PARP(85) = 1.0D0
64190           PARP(86) = 1.0D0
64191 C...ISR cutoff, muR scale factor, and phase space size
64192           PARP(62) = 1.25D0
64193           PARP(64) = 0.2D0
64194           PARP(67) = 1D0
64195 C...Intrinsic kT, size, and max
64196           MSTP(91) = 1
64197           PARP(91) = 2.1D0
64198           PARP(93) = 15D0
64199  
64200 C...Tune DW
64201         ELSEIF (ITUNEB.EQ.103) THEN
64202 C...pT0.
64203           PARP(82) = 1.9D0
64204 c...String drawing completely minimizes string length.
64205           PARP(85) = 1.0D0
64206           PARP(86) = 1.0D0
64207 C...ISR cutoff, muR scale factor, and phase space size
64208           PARP(62) = 1.25D0
64209           PARP(64) = 0.2D0
64210           PARP(67) = 2.5D0
64211 C...Intrinsic kT, size, and max
64212           MSTP(91) = 1
64213           PARP(91) = 2.1D0
64214           PARP(93) = 15D0
64215  
64216 C...Tune DWT
64217         ELSEIF (ITUNEB.EQ.104) THEN
64218 C...pT0.
64219           PARP(82) = 1.9409D0
64220 C...Run II ref scale and slow scaling
64221           PARP(89) = 1960D0
64222           PARP(90) = 0.16D0
64223 c...String drawing completely minimizes string length.
64224           PARP(85) = 1.0D0
64225           PARP(86) = 1.0D0
64226 C...ISR cutoff, muR scale factor, and phase space size
64227           PARP(62) = 1.25D0
64228           PARP(64) = 0.2D0
64229           PARP(67) = 2.5D0
64230 C...Intrinsic kT, size, and max
64231           MSTP(91) = 1
64232           PARP(91) = 2.1D0
64233           PARP(93) = 15D0
64234  
64235 C...Tune QW
64236         ELSEIF(ITUNEB.EQ.105) THEN
64237           IF (M13.GE.1) THEN
64238             WRITE(M11,5030) ' '
64239             CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
64240      &           'externally linked'
64241             WRITE(M11,5035) CH70
64242           ENDIF
64243 C...pT0.
64244           PARP(82) = 1.1D0
64245 c...String drawing completely minimizes string length.
64246           PARP(85) = 1.0D0
64247           PARP(86) = 1.0D0
64248 C...ISR cutoff, muR scale factor, and phase space size
64249           PARP(62) = 1.25D0
64250           PARP(64) = 0.2D0
64251           PARP(67) = 2.5D0
64252 C...Intrinsic kT, size, and max
64253           MSTP(91) = 1
64254           PARP(91) = 2.1D0
64255           PARP(93) = 15D0
64256  
64257 C...Tune D6 and D6T
64258         ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
64259           IF (M13.GE.1) THEN
64260             WRITE(M11,5030) ' '
64261             CH70='NB! This tune requires CTEQ6L pdfs to be '//
64262      &           'externally linked'
64263             WRITE(M11,5035) CH70
64264           ENDIF
64265 C...The "Rick" proton, double gauss with 0.5/0.4
64266           MSTP(82) = 4
64267           PARP(83) = 0.5D0
64268           PARP(84) = 0.4D0
64269 c...String drawing completely minimizes string length.
64270           PARP(85) = 1.0D0
64271           PARP(86) = 1.0D0
64272           IF (ITUNEB.EQ.108) THEN
64273 C...D6: pT0, Run I ref scale, and fast energy scaling
64274             PARP(82) = 1.8D0
64275             PARP(89) = 1800D0
64276             PARP(90) = 0.25D0
64277           ELSE
64278 C...D6T: pT0, Run II ref scale, and slow energy scaling
64279             PARP(82) = 1.8387D0
64280             PARP(89) = 1960D0
64281             PARP(90) = 0.16D0
64282           ENDIF
64283 C...ISR cutoff, muR scale factor, and phase space size
64284           PARP(62) = 1.25D0
64285           PARP(64) = 0.2D0
64286           PARP(67) = 2.5D0
64287 C...Intrinsic kT, size, and max
64288           MSTP(91) = 1
64289           PARP(91) = 2.1D0
64290           PARP(93) = 15D0
64291  
64292 C...Old ATLAS-DC2 5-parameter tune
64293         ELSEIF(ITUNEB.EQ.106) THEN
64294           IF (M13.GE.1) THEN
64295             WRITE(M11,5010) ITUNE, CHNAME
64296             CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
64297             WRITE(M11,5030) CH60
64298             CH60='    R. Field in hep-ph/0610012,'
64299             WRITE(M11,5030) CH60
64300             CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64301             WRITE(M11,5030) CH60
64302           ENDIF
64303 C...  pT0.
64304           PARP(82) = 1.8D0
64305 C...  Different ref and rescaling pacee
64306           PARP(89) = 1000D0
64307           PARP(90) = 0.16D0
64308 C...  Parameters of mass distribution
64309           PARP(83) = 0.5D0
64310           PARP(84) = 0.5D0
64311 C...  Old default string drawing
64312           PARP(85) = 0.33D0
64313           PARP(86) = 0.66D0
64314 C...  ISR, phase space equivalent to Tune B
64315           PARP(62) = 1D0
64316           PARP(64) = 1D0
64317           PARP(67) = 1D0
64318 C...  FSR
64319           PARP(71) = 4D0
64320 C...  Intrinsic kT
64321           MSTP(91) = 1
64322           PARP(91) = 1D0
64323           PARP(93) = 5D0
64324  
64325 C...Professor's Pro-Q2O Tune
64326         ELSEIF(ITUNE.EQ.129) THEN
64327           PARP(62) = 2.9
64328           PARP(64) = 0.14
64329           PARP(67) = 2.65
64330           PARP(82) = 1.9
64331           PARP(83) = 0.83
64332           PARP(84) = 0.6
64333           PARP(85) = 0.86
64334           PARP(86) = 0.93
64335           PARP(89) = 1800D0
64336           PARP(90) = 0.22
64337           MSTP(91) = 1
64338           PARP(91) = 2.1
64339           PARP(93) = 5.0
64340  
64341         ENDIF
64342  
64343 C...  Output
64344         IF (M13.GE.1) THEN
64345           WRITE(M11,5030) ' '
64346           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64347           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64348           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
64349           WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64350           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64351           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
64352           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64353           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64354           WRITE(M11,5030) CH60
64355           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64356           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64357           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64358           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64359           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64360           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64361           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64362           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64363           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64364           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64365           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64366           IF (MSTP(82).GE.2) THEN
64367             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
64368             IF (PARP(87).GE.0D0) 
64369      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
64370           ENDIF
64371           WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64372           WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64373           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64374           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64375           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64376 
64377         ENDIF
64378  
64379 C=======================================================================
64380 C... ACR, tune A with new CR (107)
64381       ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
64382         IF (M13.GE.1) THEN
64383           WRITE(M11,5010) ITUNE, CHNAME
64384           CH60='Tune A modified with new colour reconnections'
64385           WRITE(M11,5030) CH60
64386           CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
64387           WRITE(M11,5030) CH60
64388           CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
64389           WRITE(M11,5030) CH60
64390           CH60='    R. Field, in hep-ph/0610012 (Tune A),'
64391           WRITE(M11,5030) CH60
64392           CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64393           WRITE(M11,5030) CH60
64394           IF (ITUNE.EQ.117) THEN
64395             CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64396             WRITE(M11,5030) CH60
64397           ENDIF
64398         ENDIF
64399         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
64400           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64401      &        ' with tune. Using defaults.')
64402           GOTO 100
64403         ENDIF
64404  
64405 C...Make sure we start from old default fragmentation parameters
64406         PARJ(81) = 0.29
64407         PARJ(82) = 1.0
64408  
64409 C...Use Professor's LEP pars if ITUNE >= 110
64410 C...(i.e., for A-Pro, DW-Pro etc)
64411         IF (ITUNE.LT.110) THEN
64412 C...# Old defaults
64413           MSTJ(11) = 4
64414 C...# Old default flavour parameters
64415           PARJ(21) = 0.36
64416           PARJ(41) = 0.30
64417           PARJ(42) = 0.58
64418           PARJ(46) = 1.0
64419           PARJ(82) = 1.0
64420         ELSE
64421 C...# Tuned flavour parameters:
64422           PARJ(1)  = 0.073
64423           PARJ(2)  = 0.2
64424           PARJ(3)  = 0.94
64425           PARJ(4)  = 0.032
64426           PARJ(11) = 0.31
64427           PARJ(12) = 0.4
64428           PARJ(13) = 0.54
64429           PARJ(25) = 0.63
64430           PARJ(26) = 0.12
64431 C...# Switch on Bowler:
64432           MSTJ(11) = 5
64433 C...# Fragmentation
64434           PARJ(21) = 0.325
64435           PARJ(41) = 0.5
64436           PARJ(42) = 0.6
64437           PARJ(47) = 0.67
64438           PARJ(81) = 0.29
64439           PARJ(82) = 1.65
64440         ENDIF
64441  
64442         MSTP(81) = 1
64443         PARP(89) = 1800D0
64444         PARP(90) = 0.25D0
64445         MSTP(82) = 4
64446         PARP(83) = 0.5D0
64447         PARP(84) = 0.4D0
64448         MSTP(51) = 7
64449         MSTP(52) = 1
64450         PARP(71) = 4D0
64451         PARP(82) = 2.0D0
64452         PARP(85) = 0.0D0
64453         PARP(86) = 0.66D0
64454         PARP(62) = 1D0
64455         PARP(64) = 1D0
64456         PARP(67) = 4D0
64457         MSTP(91) = 1
64458         PARP(91) = 1D0
64459         PARP(93) = 5D0
64460         MSTP(95) = 6
64461 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
64462         PARP(78) = 0.09D0
64463 C...Frag functions (only if not using Professor)
64464         IF (ITUNE.LE.109) THEN
64465           MSTJ(11) = 4
64466           PARJ(54) = -0.05
64467           PARJ(55) = -0.005
64468         ENDIF
64469  
64470 C...Output
64471         IF (M13.GE.1) THEN
64472           WRITE(M11,5030) ' '
64473           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64474           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64475           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
64476           WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64477           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64478           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
64479           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64480           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64481           WRITE(M11,5030) CH60
64482           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64483           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64484           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64485           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64486           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64487           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64488           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64489           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64490           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64491           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64492           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64493           IF (MSTP(82).GE.2) THEN
64494             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
64495             IF (PARP(87).GE.0D0) 
64496      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
64497           ENDIF
64498           WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64499           WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64500           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64501           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64502           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64503           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
64504           WRITE(M11,5050) 78, PARP(78), CHPARP(78)
64505 
64506         ENDIF
64507  
64508 C=======================================================================
64509 C...Intermediate model. Rap tune
64510 C...(retuned to post-6.406 IR factorization)
64511       ELSEIF(ITUNE.EQ.200) THEN
64512         IF (M13.GE.1) THEN
64513           WRITE(M11,5010) ITUNE, CHNAME
64514           CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
64515           WRITE(M11,5030) CH60
64516         ENDIF
64517         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
64518           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64519      &        ' with tune.')
64520         ENDIF
64521 C...PDF
64522         MSTP(51) = 7
64523         MSTP(52) = 1
64524 C...ISR
64525         PARP(62) = 1D0
64526         PARP(64) = 1D0
64527         PARP(67) = 4D0
64528 C...FSR
64529         PARP(71) = 4D0
64530         PARJ(81) = 0.29D0
64531 C...UE
64532         MSTP(81) = 11
64533         PARP(82) = 2.25D0
64534         PARP(89) = 1800D0
64535         PARP(90) = 0.25D0
64536 C...  ExpOfPow(1.8) overlap profile
64537         MSTP(82) = 5
64538         PARP(83) = 1.8D0
64539 C...  Valence qq
64540         MSTP(88) = 0
64541 C...  Rap Tune
64542         MSTP(89) = 1
64543 C...  Default diquark, BR-g-BR supp
64544         PARP(79) = 2D0
64545         PARP(80) = 0.01D0
64546 C...  Final state reconnect.
64547         MSTP(95) = 1
64548         PARP(78) = 0.55D0
64549 C...Fragmentation functions and c and b parameters
64550         MSTJ(11) = 4
64551         PARJ(54) = -0.05
64552         PARJ(55) = -0.005
64553 C...  Output
64554         IF (M13.GE.1) THEN
64555           WRITE(M11,5030) ' '
64556           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64557           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64558           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
64559           WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64560           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64561           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
64562           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64563           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64564           WRITE(M11,5030) CH60
64565           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64566           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64567           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64568           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64569           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64570           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64571           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64572           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64573           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64574           IF (MSTP(82).GE.2) THEN
64575             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
64576             IF (PARP(87).GE.0D0) 
64577      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
64578           ENDIF
64579           WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
64580           WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
64581           WRITE(M11,5050) 79, PARP(79), CHPARP(79)
64582           WRITE(M11,5050) 80, PARP(80), CHPARP(80)
64583           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64584           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
64585           WRITE(M11,5050) 78, PARP(78), CHPARP(78)
64586 
64587         ENDIF
64588  
64589 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
64590 C...Old model for ISR and UE, new pT-ordered model for FSR
64591       ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
64592      &       .ITUNE.EQ.226) THEN
64593         IF (M13.GE.1) THEN
64594           WRITE(M11,5010) ITUNE, CHNAME
64595           CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
64596           WRITE(M11,5030) CH60
64597           CH60='    R.D. Field, in hep-ph/0610012 (Tune A)'
64598           WRITE(M11,5030) CH60
64599           CH60='    T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64600           WRITE(M11,5030) CH60
64601           CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
64602           WRITE(M11,5030) CH60
64603           IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
64604             CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64605             WRITE(M11,5030) CH60
64606           ENDIF
64607         ENDIF
64608         IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
64609           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64610      &        ' with tune.')
64611         ENDIF
64612 C...First set as if Pythia tune A
64613 C...Multiple interactions on, old framework
64614         MSTP(81) = 1
64615 C...Fast IR cutoff energy scaling by default
64616         PARP(89) = 1800D0
64617         PARP(90) = 0.25D0
64618 C...Default CTEQ5L (internal)
64619         MSTP(51) = 7
64620         MSTP(52) = 1
64621 C...Double Gaussian matter distribution.
64622         MSTP(82) = 4
64623         PARP(83) = 0.5D0
64624         PARP(84) = 0.4D0
64625 C...FSR activity.
64626         PARP(71) = 4D0
64627 c...String drawing almost completely minimizes string length.
64628         PARP(85) = 0.9D0
64629         PARP(86) = 0.95D0
64630 C...ISR cutoff, muR scale factor, and phase space size
64631         PARP(62) = 1D0
64632         PARP(64) = 1D0
64633         PARP(67) = 4D0
64634 C...Intrinsic kT, size, and max
64635         MSTP(91) = 1
64636         PARP(91) = 1D0
64637         PARP(93) = 5D0
64638 C...Use 2 GeV of primordial kT for "Perugia" version
64639         IF (ITUNE.EQ.221) THEN
64640           PARP(91) = 2D0
64641           PARP(93) = 10D0
64642         ENDIF
64643 C...Use pT-ordered FSR
64644         MSTJ(41) = 12
64645 C...Lambda_FSR scale for pT-ordering
64646         PARJ(81) = 0.23D0
64647 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
64648         PARP(82) = 2.05D0
64649 C...Fragmentation functions and c and b parameters
64650 C...(overwritten for 211, i.e., if using Professor pars)
64651         PARJ(54) = -0.05
64652         PARJ(55) = -0.005
64653  
64654 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
64655         IF (ITUNE.LT.210) THEN
64656 C...# Old defaults
64657           MSTJ(11) = 4
64658 C...# Old default flavour parameters
64659           PARJ(21) = 0.36
64660           PARJ(41) = 0.30
64661           PARJ(42) = 0.58
64662           PARJ(46) = 1.0
64663           PARJ(82) = 1.0
64664         ELSE
64665 C...# Tuned flavour parameters:
64666           PARJ(1)  = 0.073
64667           PARJ(2)  = 0.2
64668           PARJ(3)  = 0.94
64669           PARJ(4)  = 0.032
64670           PARJ(11) = 0.31
64671           PARJ(12) = 0.4
64672           PARJ(13) = 0.54
64673           PARJ(25) = 0.63
64674           PARJ(26) = 0.12
64675 C...# Always use pT-ordered shower:
64676           MSTJ(41) = 12
64677 C...# Switch on Bowler:
64678           MSTJ(11) = 5
64679 C...# Fragmentation
64680           PARJ(21) = 3.1327e-01
64681           PARJ(41) = 4.8989e-01
64682           PARJ(42) = 1.2018e+00
64683           PARJ(47) = 1.0000e+00
64684           PARJ(81) = 2.5696e-01
64685           PARJ(82) = 8.0000e-01
64686         ENDIF
64687  
64688 C...221, 226 : Perugia-APT and Perugia-APT6
64689         IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
64690  
64691           PARP(64) = 0.5D0
64692           PARP(82) = 2.05D0
64693           PARP(90) = 0.26D0
64694           PARP(91) = 2.0D0
64695 C...The Perugia variants use Steve's showers off the old MPI
64696           MSTP(152) = 1
64697 C...And use a lower PARP(71) as suggested by Professor tunings
64698 C...(although not certain that applies to Q2-pT2 hybrid)
64699           PARP(71) = 2.5D0
64700  
64701 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
64702           IF (ITUNE.EQ.226) THEN
64703             CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
64704      &           'externally linked'
64705             WRITE(M11,5035) CH70
64706             MSTP(52) = 2
64707             MSTP(51) = 10042
64708             PARP(82) = 1.95D0
64709           ENDIF
64710  
64711         ENDIF
64712  
64713 C...  Output
64714         IF (M13.GE.1) THEN
64715           WRITE(M11,5030) ' '
64716           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64717           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64718           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
64719           WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64720           WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64721           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
64722           WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64723           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64724           WRITE(M11,5030) CH60
64725           WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
64726           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64727           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64728           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64729           WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64730           WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64731           WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64732           WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64733           WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64734           WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64735           WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64736           IF (MSTP(82).GE.2) THEN
64737             WRITE(M11,5050) 87, PARP(87), CHPARP(87)
64738             IF (PARP(87).GE.0D0) 
64739      &           WRITE(M11,5050) 88, PARP(88), CHPARP(88)            
64740           ENDIF
64741           WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64742           WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64743           WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64744           WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64745           WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64746 
64747         ENDIF
64748  
64749 C======================================================================
64750 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
64751       ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
64752         IF (M13.GE.1) THEN
64753           WRITE(M11,5010) ITUNE, CHNAME
64754           CH60='see J. Rathsman, PLB452(1999)364'
64755           WRITE(M11,5030) CH60
64756           CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64757           WRITE(M11,5030) CH60
64758         ENDIF
64759 C...GAL Recommended settings from Uppsala web page 
64760         MSTP(95) = 13
64761         PARP(78) = 0.10
64762         MSTJ(16) = 0
64763         PARJ(42) = 0.45
64764         PARJ(82) = 2.0
64765         PARP(62) = 2.0
64766         MSTP(81) = 1
64767         MSTP(82) = 1
64768         PARP(81) = 1.9
64769         MSTP(92) = 1
64770         IF(CHNAME.EQ.'GAL Tune 1') THEN
64771 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
64772           MSTP(82) = 4
64773           PARP(83) = 0.25D0
64774           PARP(84) = 0.5D0
64775           PARP(82) = 1.75
64776           IF (M13.GE.1) THEN
64777             WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64778             WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64779             WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64780             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64781             WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64782           ENDIF
64783         ELSE
64784           IF (M13.GE.1) THEN
64785             WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64786             WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64787             WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64788           ENDIF
64789         ENDIF
64790 C...Output
64791         IF (M13.GE.1) THEN
64792           WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64793           WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64794           WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64795           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
64796           WRITE(M11,5050) 78, PARP(78), CHPARP(78)
64797           WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64798           WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64799         ENDIF
64800       ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
64801         IF (M13.GE.1) THEN
64802           WRITE(M11,5010) ITUNE, CHNAME
64803           CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
64804           WRITE(M11,5030) CH60
64805           CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64806           WRITE(M11,5030) CH60
64807           WRITE(M11,5030) ' '
64808           CH70='NB! The SCI model must be run with modified '//
64809      &        'Pythia v6.215:'
64810           WRITE(M11,5035) CH70
64811           CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64812           WRITE(M11,5035) CH70
64813           WRITE(M11,5030) ' '
64814         ENDIF
64815 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
64816         MSTP(81) = 1
64817         MSTP(82) = 1
64818         PARP(81) = 2.2
64819         MSTP(92) = 1
64820         MSTP(95) = 11
64821         PARP(78) = 0.50
64822         MSTJ(16) = 0
64823         IF (CHNAME.EQ.'SCI Tune 1') THEN
64824 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
64825           MSTP(81) = 1
64826           MSTP(82) = 3
64827           PARP(82) = 2.4
64828           PARP(83) = 0.5D0
64829           PARP(62) = 1.5
64830           PARP(84) = 0.25D0
64831           IF (M13.GE.1) THEN
64832             WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64833             WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64834             WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64835             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64836             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64837           ENDIF
64838         ELSE
64839           IF (M13.GE.1) THEN
64840             WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64841             WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64842             WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64843           ENDIF
64844         ENDIF
64845 C...Output
64846         IF (M13.GE.1) THEN
64847           WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64848           WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
64849           WRITE(M11,5050) 78, PARP(78), CHPARP(78)
64850           WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64851         ENDIF
64852  
64853       ELSE
64854         IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
64855  
64856       ENDIF
64857  
64858 C...Output of LEP parameters, common to all models
64859       IF (M13.GE.1) THEN
64860         WRITE(M11,5080) 
64861         WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
64862         IF (MSTJ(11).EQ.3) THEN
64863           CH60='Warning: using Peterson fragmentation function'
64864           WRITE(M11,5030) CH60 
64865         ENDIF
64866         
64867         WRITE(M11,5060)  1, PARJ( 1), CHPARJ( 1)
64868         WRITE(M11,5060)  2, PARJ( 2), CHPARJ( 2)
64869         WRITE(M11,5060)  3, PARJ( 3), CHPARJ( 3)
64870         WRITE(M11,5060)  4, PARJ( 4), CHPARJ( 4)
64871         WRITE(M11,5060)  5, PARJ( 5), CHPARJ( 5)
64872         WRITE(M11,5060)  6, PARJ( 6), CHPARJ( 6)
64873         WRITE(M11,5060)  7, PARJ( 7), CHPARJ( 7)
64874         
64875         WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
64876         WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
64877         WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
64878         
64879         WRITE(M11,5060) 14, PARJ(14), CHPARJ(14)
64880         WRITE(M11,5060) 15, PARJ(15), CHPARJ(15)
64881         WRITE(M11,5060) 16, PARJ(16), CHPARJ(16)
64882         WRITE(M11,5060) 17, PARJ(17), CHPARJ(17)
64883         WRITE(M11,5060) 18, PARJ(18), CHPARJ(18)
64884         WRITE(M11,5060) 19, PARJ(19), CHPARJ(19)
64885         
64886         WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
64887         
64888         WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
64889         WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
64890         
64891         WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
64892         WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64893         WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
64894         
64895         IF (MSTJ(11).LE.3) THEN
64896           WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
64897           WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
64898         ELSE
64899           WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
64900         ENDIF
64901         IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
64902       ENDIF
64903         
64904  100  IF (MSTU(13).GE.1) WRITE(M11,6000)
64905  
64906  9999 RETURN
64907  
64908  5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
64909      &    'Presets for underlying-event (and min-bias)',21x,'*'/' *',
64910      &    12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*')
64911  5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
64912  5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
64913  5030 FORMAT(' *',3x,10x,A60,3x,'*')
64914  5035 FORMAT(' *',3x,A70,3x,'*')
64915  5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
64916  5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
64917  5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
64918  5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
64919  5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
64920  6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
64921  6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
64922 C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
64923 C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
64924  6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
64925 C 6040 FORMAT(' *',5x,'MSWI(',I1,')  = ',I12,3x,A40,5x,'*')
64926 C 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
64927  
64928       END
64929 
64930 C*********************************************************************
64931  
64932 C...PYEXEC
64933 C...Administrates the fragmentation and decay chain.
64934  
64935       SUBROUTINE PYEXEC
64936  
64937 C...Double precision and integer declarations.
64938       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64939       IMPLICIT INTEGER(I-N)
64940       INTEGER PYK,PYCHGE,PYCOMP
64941 C...Commonblocks.
64942       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64943       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64944       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64945       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64946       COMMON/PYINT1/MINT(400),VINT(400)
64947       COMMON/PYINT4/MWID(500),WIDS(500,5)
64948       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
64949 C...Local array.
64950       DIMENSION PS(2,6),IJOIN(100)
64951  
64952 C...Initialize and reset.
64953       MSTU(24)=0
64954       IF(MSTU(12).NE.12345) CALL PYLIST(0)
64955       MSTU(29)=0
64956       MSTU(31)=MSTU(31)+1
64957       MSTU(1)=0
64958       MSTU(2)=0
64959       MSTU(3)=0
64960       IF(MSTU(17).LE.0) MSTU(90)=0
64961       MCONS=1
64962  
64963 C...Sum up momentum, energy and charge for starting entries.
64964       NSAV=N
64965       DO 110 I=1,2
64966         DO 100 J=1,6
64967           PS(I,J)=0D0
64968   100   CONTINUE
64969   110 CONTINUE
64970       DO 130 I=1,N
64971         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
64972         DO 120 J=1,4
64973           PS(1,J)=PS(1,J)+P(I,J)
64974   120   CONTINUE
64975         PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
64976   130 CONTINUE
64977       PARU(21)=PS(1,4)
64978  
64979 C...Start by all decays of coloured resonances involved in shower.
64980       NORIG=N
64981       DO 140 I=1,NORIG
64982         IF(K(I,1).EQ.3) THEN
64983           KC=PYCOMP(K(I,2))
64984           IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
64985         ENDIF
64986   140 CONTINUE
64987  
64988 C...Prepare system for subsequent fragmentation/decay.
64989       CALL PYPREP(0)
64990       IF(MINT(51).NE.0) RETURN
64991  
64992 C...Loop through jet fragmentation and particle decays.
64993       MBE=0
64994   150 MBE=MBE+1
64995       IP=0
64996   160 IP=IP+1
64997       KC=0
64998       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
64999       IF(KC.EQ.0) THEN
65000  
65001 C...Deal with any remaining undecayed resonance
65002 C...(normally the task of PYEVNT, so seldom used).
65003       ELSEIF(MWID(KC).NE.0) THEN
65004         IBEG=IP
65005         IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
65006           IBEG=IP+1
65007   170     IBEG=IBEG-1
65008           IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
65009           IF(K(IBEG,1).NE.2) IBEG=IBEG+1
65010           IEND=IP-1
65011   180     IEND=IEND+1
65012           IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
65013           IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
65014           NJOIN=0
65015           DO 190 I=IBEG,IEND
65016             IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
65017               NJOIN=NJOIN+1
65018               IJOIN(NJOIN)=I
65019             ENDIF
65020   190     CONTINUE
65021         ENDIF
65022         CALL PYRESD(IP)
65023         CALL PYPREP(IBEG)
65024         IF(MINT(51).NE.0) RETURN
65025  
65026 C...Particle decay if unstable and allowed. Save long-lived particle
65027 C...decays until second pass after Bose-Einstein effects.
65028       ELSEIF(KCHG(KC,2).EQ.0) THEN
65029         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
65030      &  .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
65031      &  CALL PYDECY(IP)
65032  
65033 C...Decay products may develop a shower.
65034         IF(MSTJ(92).GT.0) THEN
65035           IP1=MSTJ(92)
65036           QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
65037      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
65038           MINT(33)=0
65039           CALL PYSHOW(IP1,IP1+1,QMAX)
65040           CALL PYPREP(IP1)
65041           IF(MINT(51).NE.0) RETURN
65042           MSTJ(92)=0
65043         ELSEIF(MSTJ(92).LT.0) THEN
65044           IP1=-MSTJ(92)
65045           MINT(33)=0
65046           CALL PYSHOW(IP1,-3,P(IP,5))
65047           CALL PYPREP(IP1)
65048           IF(MINT(51).NE.0) RETURN
65049           MSTJ(92)=0
65050         ENDIF
65051  
65052 C...Jet fragmentation: string or independent fragmentation.
65053       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
65054         MFRAG=MSTJ(1)
65055         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
65056         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
65057           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
65058      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
65059             IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
65060           ENDIF
65061         ENDIF
65062         IF(MFRAG.EQ.1) CALL PYSTRF(IP)
65063         IF(MFRAG.EQ.2) CALL PYINDF(IP)
65064         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
65065         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
65066       ENDIF
65067  
65068 C...Loop back if enough space left in PYJETS and no error abort.
65069       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
65070       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
65071         GOTO 160
65072       ELSEIF(IP.LT.N) THEN
65073         CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
65074       ENDIF
65075  
65076 C...Include simple Bose-Einstein effect parametrization if desired.
65077       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
65078         CALL PYBOEI(NSAV)
65079         GOTO 150
65080       ENDIF
65081  
65082 C...Check that momentum, energy and charge were conserved.
65083       DO 210 I=1,N
65084         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
65085         DO 200 J=1,4
65086           PS(2,J)=PS(2,J)+P(I,J)
65087   200   CONTINUE
65088         PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
65089   210 CONTINUE
65090       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
65091      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
65092       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
65093      &'(PYEXEC:) four-momentum was not conserved')
65094       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
65095      &'(PYEXEC:) charge was not conserved')
65096  
65097       RETURN
65098       END
65099  
65100 C*********************************************************************
65101  
65102 C...PYPREP
65103 C...Rearranges partons along strings.
65104 C...Special considerations for systems with junctions, with
65105 C...possibility of junction-antijunction annihilation.
65106 C...Allows small systems to collapse into one or two particles.
65107 C...Checks flavours and colour singlet invariant masses.
65108  
65109       SUBROUTINE PYPREP(IP)
65110  
65111 C...Double precision and integer declarations.
65112       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65113       INTEGER PYK,PYCHGE,PYCOMP
65114 C...Commonblocks.
65115       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65116       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65117       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65118       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65119       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
65120       COMMON/PYINT1/MINT(400),VINT(400)
65121 C...The common block of colour tags.
65122       COMMON/PYCTAG/NCT,MCT(4000,2)
65123       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
65124      &/PYPARS/
65125       DATA NERRPR/0/
65126       SAVE NERRPR
65127 C...Local arrays.
65128       DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
65129      &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
65130      &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
65131      &IJCP(0:6),TJUOLD(5)
65132       CHARACTER CHTMP*6
65133  
65134 C...Function to give four-product.
65135       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)
65136  
65137 C...Rearrange parton shower product listing along strings: begin loop.
65138       MSTU(24)=0
65139       NOLD=N
65140       I1=N
65141       NJUNC=0
65142       NPIECE=0
65143       NJJSTR=0
65144       MSTU32=MSTU(32)+1
65145       DO 100 I=MAX(1,IP),N
65146 C...First store junction positions.
65147         IF(K(I,1).EQ.42) THEN
65148           NJUNC=NJUNC+1
65149           IJUNC(NJUNC,0)=I
65150           IJUNC(NJUNC,4)=0
65151         ENDIF
65152   100 CONTINUE
65153  
65154       DO 250 MQGST=1,3
65155         DO 240 I=MAX(1,IP),N
65156 C...Special treatment for junctions
65157           IF (K(I,1).LE.0) GOTO 240
65158           IF(K(I,1).EQ.42) THEN
65159 C...MQGST=2: Look for junction-junction strings (not detected in the
65160 C...main search below).
65161             IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
65162               IF (NJJSTR.EQ.0) THEN
65163                 NJJSTR = (3*NJUNC-NPIECE)/2
65164               ENDIF
65165 C...Check how many already identified strings end on this junction
65166               ILC=0
65167               DO 110 J=1,NPIECE
65168                 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
65169   110         CONTINUE
65170 C...If less than 3, remaining must be to another junction
65171               IF (ILC.LT.3) THEN
65172                 IF (ILC.NE.2) THEN
65173 C...Multiple j-j connections not handled yet.
65174                   CALL PYERRM(2,
65175      &            '(PYPREP:) Too many junction-junction strings.')
65176                   MINT(51)=1
65177                   RETURN
65178                 ENDIF
65179 C...The colour information in the junction is unreadable for the
65180 C...colour space search further down in this routine, so we must
65181 C...start on the colour mother of this junction and then "artificially"
65182 C...prevent the colour mother from connecting here again.
65183                 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
65184                 KCS=4
65185                 IF (MOD(ITJUNC,2).EQ.0) KCS=5
65186 C...Switch colour if the junction-junction leg is presumably a
65187 C...junction mother leg rather than a junction daughter leg.
65188                 IF (ITJUNC.GE.3) KCS=9-KCS
65189                 IF (MINT(33).EQ.0) THEN
65190 C...Find the unconnected leg and reorder junction daughter pointers so
65191 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
65192 C...piece.
65193                   IA=MOD(K(I,4),MSTU(5))
65194                   IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
65195                     ITMP=MOD(K(I,5),MSTU(5))
65196                     IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
65197                       ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
65198                       K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
65199                     ELSE
65200                       K(I,5)=K(I,5)+(IA-ITMP)
65201                     ENDIF
65202                     K(I,4)=K(I,4)+(ITMP-IA)
65203                     IA=ITMP
65204                   ENDIF
65205                   IF (ITJUNC.LE.2) THEN
65206 C...Beam baryon junction
65207                     K(IA,KCS)   = K(IA,KCS) + 2*MSTU(5)**2
65208                     K(I,KCS)    = K(I,KCS) + 1*MSTU(5)**2
65209 C...Else 1 -> 2 decay junction
65210                   ELSE
65211                     K(IA,KCS)   = K(IA,KCS) + MSTU(5)**2
65212                     K(I,KCS)    = K(I,KCS) + 2*MSTU(5)**2
65213                   ENDIF
65214                   I1BEG = I1
65215                   NSTP = 0
65216                   GOTO 170
65217 C...Alternatively use colour tag information.
65218                 ELSE
65219 C...Find a final state parton with appropriate dangling colour tag.
65220                   JCT=0
65221                   IA=0
65222                   IJUMO=K(I,3)
65223                   DO 140 J1=MAX(1,IP),N
65224                     IF (K(J1,1).NE.3) GOTO 140
65225 C...Check for matching final-state colour tag
65226                     IMATCH=0
65227                     DO 120 J2=MAX(1,IP),N
65228                       IF (K(J2,1).NE.3) GOTO 120
65229                       IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
65230   120               CONTINUE
65231                     IF (IMATCH.EQ.1) GOTO 140
65232 C...Check whether this colour tag belongs to the present junction
65233 C...by seeing whether any parton with this colour tag has the same
65234 C...mother as the junction.
65235                     JCT=MCT(J1,KCS-3)
65236                     IMATCH=0
65237                     DO 130 J2=MINT(84)+1,N
65238                       IMO2=K(J2,3)
65239 C...First scattering partons have IMO1 = 3 and 4.
65240                       IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
65241      &                     IMO2=IMO2-2
65242                       IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
65243      &                     IMATCH=1
65244   130               CONTINUE
65245                     IF (IMATCH.EQ.0) GOTO 140
65246                     IA=J1
65247   140             CONTINUE
65248 C...Check for junction-junction strings without intermediate final state
65249 C...glue (not detected above).
65250                   IF (IA.EQ.0) THEN
65251                     DO 160 MJU=1,NJUNC
65252                       IJU2=IJUNC(MJU,0)
65253                       IF (IJU2.EQ.I) GOTO 160
65254                       ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
65255 C...Only opposite types of junctions can connect to each other.
65256                       IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
65257                       IS=0
65258                       DO 150 J=1,NPIECE
65259                         IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
65260   150                 CONTINUE
65261                       IF (IS.EQ.3) GOTO 160
65262                       IB=I
65263                       IA=IJU2
65264   160               CONTINUE
65265                   ENDIF
65266 C...Switch to other side of adjacent parton and step from there.
65267                   KCS=9-KCS
65268                   I1BEG = I1
65269                   NSTP = 0
65270                   GOTO 170
65271                 ENDIF
65272               ELSE IF (ILC.NE.3) THEN
65273               ENDIF
65274             ENDIF
65275           ENDIF
65276  
65277 C...Look for coloured string endpoint, or (later) leftover gluon.
65278           IF(K(I,1).NE.3) GOTO 240
65279           KC=PYCOMP(K(I,2))
65280           IF(KC.EQ.0) GOTO 240
65281           KQ=KCHG(KC,2)
65282           IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
65283  
65284 C...Pick up loose string end.
65285           KCS=4
65286           IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
65287           IA=I
65288           IB=I
65289           I1BEG=I1
65290           NSTP=0
65291   170     NSTP=NSTP+1
65292           IF(NSTP.GT.4*N) THEN
65293             CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
65294             MINT(51)=1
65295             RETURN
65296           ENDIF
65297  
65298 C...Copy undecayed parton. Finished if reached string endpoint.
65299           IF(K(IA,1).EQ.3) THEN
65300             IF(I1.GE.MSTU(4)-MSTU32-5) THEN
65301               CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
65302               MINT(51)=1
65303               MSTU(24)=1
65304               RETURN
65305             ENDIF
65306             I1=I1+1
65307             K(I1,1)=2
65308             IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
65309             K(I1,2)=K(IA,2)
65310             K(I1,3)=IA
65311             K(I1,4)=0
65312             K(I1,5)=0
65313             DO 180 J=1,5
65314               P(I1,J)=P(IA,J)
65315               V(I1,J)=V(IA,J)
65316   180       CONTINUE
65317             K(IA,1)=K(IA,1)+10
65318             IF(K(I1,1).EQ.1) GOTO 240
65319           ENDIF
65320  
65321 C...Also finished (for now) if reached junction; then copy to end.
65322           IF(K(IA,1).EQ.42) THEN
65323             NCOPY=I1-I1BEG
65324             IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
65325               CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
65326               MINT(51)=1
65327               MSTU(24)=1
65328               RETURN
65329             ENDIF
65330             IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
65331               DO 200 ICOPY=1,NCOPY
65332                 DO 190 J=1,5
65333                   K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
65334                   P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
65335                   V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
65336   190           CONTINUE
65337   200         CONTINUE
65338             ENDIF
65339 C...For junction-junction strings, find end leg and reorder junction
65340 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
65341 C...junction-junction string piece.
65342             IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
65343               ITMP=MOD(K(IA,4),MSTU(5))
65344               IF (ITMP.NE.IB) THEN
65345                 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
65346                   K(IA,5)=K(IA,5)+(ITMP-IB)
65347                 ELSE
65348                   K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
65349                 ENDIF
65350                 K(IA,4)=K(IA,4)+(IB-ITMP)
65351               ENDIF
65352             ENDIF
65353             NPIECE=NPIECE+1
65354 C...IPIECE:
65355 C...0: endpoint in original ER
65356 C...1:
65357 C...2:
65358 C...3: Parton immediately next to junction
65359 C...4: Junction
65360             IPIECE(NPIECE,0)=I
65361             IPIECE(NPIECE,1)=MSTU32+1
65362             IPIECE(NPIECE,2)=MSTU32+NCOPY
65363             IPIECE(NPIECE,3)=IB
65364             IPIECE(NPIECE,4)=IA
65365             MSTU32=MSTU32+NCOPY
65366             I1=I1BEG
65367             GOTO 240
65368           ENDIF
65369  
65370 C...GOTO next parton in colour space.
65371           IB=IA
65372           IF (MINT(33).EQ.0) THEN
65373             IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
65374      &           )).NE.0) THEN
65375               IA=MOD(K(IB,KCS),MSTU(5))
65376               K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
65377               MREV=0
65378             ELSE
65379               IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
65380      &             MSTU(5)).EQ.0) KCS=9-KCS
65381               IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
65382               K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
65383               MREV=1
65384             ENDIF
65385             IF(IA.LE.0.OR.IA.GT.N) THEN
65386               CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
65387               IF(NERRPR.LT.5) THEN
65388                 NERRPR=NERRPR+1
65389                 WRITE(MSTU(11),*) 'started at:', I
65390                 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
65391                 WRITE(MSTU(11),*) 'MQGST =',MQGST
65392                 CALL PYLIST(4)
65393               ENDIF
65394               MINT(51)=1
65395               RETURN
65396             ENDIF
65397             IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
65398      &           ,MSTU(5)).EQ.IB) THEN
65399               IF(MREV.EQ.1) KCS=9-KCS
65400               IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
65401               K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
65402             ELSE
65403               IF(MREV.EQ.0) KCS=9-KCS
65404               IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
65405               K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
65406             ENDIF
65407             IF(IA.NE.I) GOTO 170
65408 C...Use colour tag information
65409           ELSE
65410 C...First create colour tags starting on IB if none already present.
65411             IF (MCT(IB,KCS-3).EQ.0) THEN
65412               CALL PYCTTR(IB,KCS,IB)
65413               IF(MINT(51).NE.0) RETURN
65414             ENDIF
65415             JCT=MCT(IB,KCS-3)
65416             IFOUND=0
65417 C...Find final state tag partner
65418             DO 210 IT=MAX(1,IP),N
65419               IF (IT.EQ.IB) GOTO 210
65420               IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
65421      &             .0) THEN
65422                 IFOUND=IFOUND+1
65423                 IA=IT
65424               ENDIF
65425   210       CONTINUE
65426 C...Just copy and goto next if exactly one partner found.
65427             IF (IFOUND.EQ.1) THEN
65428               GOTO 170
65429 C...When no match found, match is presumably junction.
65430             ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
65431 C...Check whether this colour tag matches a junction
65432 C...by seeing whether any parton with this colour tag has the same
65433 C...mother as a junction.
65434 C...NB: Only type 1 and 2 junctions handled presently.
65435               DO 230 IJU=1,NJUNC
65436                 IJUMO=K(IJUNC(IJU,0),3)
65437                 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
65438 C...Colours only connect to junctions, anti-colours to antijunctions:
65439                 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
65440                 IMATCH=0
65441                 DO 220 J1=MAX(1,IP),N
65442                   IF (K(J1,1).LE.0) GOTO 220
65443 C...First scattering partons have IMO1 = 3 and 4.
65444                   IMO=K(J1,3)
65445                   IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
65446      &                 IMO=IMO-2
65447                   IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
65448      &                 ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
65449      &                 IMATCH=1
65450 C...Attempt at handling type > 3 junctions also. Not tested.
65451                   IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
65452      &                 .IJUMO) IMATCH=1
65453   220           CONTINUE
65454                 IF (IMATCH.EQ.0) GOTO 230
65455                 IA=IJUNC(IJU,0)
65456                 IFOUND=IFOUND+1
65457   230         CONTINUE
65458  
65459               IF (IFOUND.EQ.1) THEN
65460                 GOTO 170
65461               ELSEIF (IFOUND.EQ.0) THEN
65462                 WRITE(CHTMP,'(I6)') JCT
65463                 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
65464      &               //CHTMP)
65465                 IF(NERRPR.LT.5) THEN
65466                   NERRPR=NERRPR+1
65467                   CALL PYLIST(4)
65468                 ENDIF
65469                 MINT(51)=1
65470                 RETURN
65471               ENDIF
65472             ELSEIF (IFOUND.GE.2) THEN
65473               WRITE(CHTMP,'(I6)') JCT
65474               CALL PYERRM(12
65475      &             ,'(PYPREP:) too many occurences of colour line: '//
65476      &             CHTMP)
65477               IF(NERRPR.LT.5) THEN
65478                 NERRPR=NERRPR+1
65479                 CALL PYLIST(4)
65480               ENDIF
65481               MINT(51)=1
65482               RETURN
65483             ENDIF
65484           ENDIF
65485           K(I1,1)=1
65486   240   CONTINUE
65487   250 CONTINUE
65488  
65489 C...Junction systems remain.
65490       IJU=0
65491       IJUS=0
65492       IJUCNT=0
65493       MREV=0
65494       IJJSTR=0
65495   260 IJUCNT=IJUCNT+1
65496       IF (IJUCNT.LE.NJUNC) THEN
65497 C...If we are not processing a j-j string, treat this junction as new.
65498         IF (IJJSTR.EQ.0) THEN
65499           IJU=IJUNC(IJUCNT,0)
65500           MREV=0
65501 C...If junction has already been read, ignore it.
65502           IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
65503 C...If we are on a j-j string, goto second j-j junction.
65504         ELSE
65505           IJUCNT=IJUCNT-1
65506           IJU=IJUS
65507         ENDIF
65508 C...Mark selected junction read.
65509         DO 270 J=1,NJUNC
65510           IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
65511   270   CONTINUE
65512 C...Determine junction type
65513         ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
65514 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
65515 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
65516 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
65517         IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
65518           IHK=0
65519   280     IHK=IHK+1
65520 C...Find which quarks belong to given junction.
65521           IHF=0
65522           DO 290 IPC=1,NPIECE
65523             IF (IPIECE(IPC,4).EQ.IJU) THEN
65524               IHF=IHF+1
65525               IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
65526             ENDIF
65527             IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
65528   290     CONTINUE
65529 C...IHK = 3 is special. Either normal string piece, or j-j string.
65530           IF(IHK.EQ.3) THEN
65531             IF (MREV.NE.1) THEN
65532               DO 300 IPC=1,NPIECE
65533 C...If there is a j-j string starting on the present junction which has
65534 C...zero length, insert next junction immediately.
65535                 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
65536      &          .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
65537                   IJJSTR = 1
65538                   GOTO 340
65539                 ENDIF
65540   300         CONTINUE
65541               MREV = 1
65542 C...If MREV is 1 and IHK is 3 we are finished with this system.
65543             ELSE
65544               MREV=0
65545               GOTO 260
65546             ENDIF
65547           ENDIF
65548  
65549 C...If we've gotten this far, then either IHK < 3, or
65550 C...an interjunction string exists, or just a third normal string.
65551           IJUNC(IJUCNT,IHK)=0
65552           IJJSTR = 0
65553 C..Order pieces belonging to this junction. Also look for j-j.
65554           DO 310 IPC=1,NPIECE
65555             IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
65556             IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
65557      &      .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
65558               IJUNC(IJUCNT,IHK)=IPC
65559               IJJSTR = 1
65560               MREV = 0
65561             ENDIF
65562   310     CONTINUE
65563 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
65564           IPC=IJUNC(IJUCNT,IHK)
65565 C...Temporary solution to cover for bug.
65566           IF(IPC.LE.0) THEN
65567             CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
65568             MINT(51)=1
65569             RETURN
65570           ENDIF
65571           DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
65572             I1=I1+1
65573             DO 320 J=1,5
65574               K(I1,J)=K(MSTU(4)-ICP,J)
65575               P(I1,J)=P(MSTU(4)-ICP,J)
65576               V(I1,J)=V(MSTU(4)-ICP,J)
65577   320       CONTINUE
65578   330     CONTINUE
65579           K(I1,1)=2
65580 C...Mark last quark.
65581           IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
65582 C...Do not insert junctions at wrong places.
65583           IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
65584 C...Insert junction.
65585   340     IJUS = IJU
65586           IF (IHK.EQ.3) THEN
65587 C...Shift to end junction if a j-j string has been processed.
65588             IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
65589             MREV= 1
65590           ENDIF
65591           I1=I1+1
65592           DO 350 J=1,5
65593             K(I1,J)=0
65594             P(I1,J)=0.
65595             V(I1,J)=0.
65596   350     CONTINUE
65597           K(I1,1)=41
65598           K(IJUS,1)=K(IJUS,1)+10
65599           K(I1,2)=K(IJUS,2)
65600           K(I1,3)=IJUS
65601   360     IF (IHK.LT.3) GOTO 280
65602         ELSE
65603           CALL PYERRM(12,'(PYPREP:) Unknown junction type')
65604           MINT(51)=1
65605           RETURN
65606         ENDIF
65607         IF (IJUCNT.NE.NJUNC) GOTO 260
65608       ENDIF
65609       N=I1
65610  
65611 C...Rearrange three strings from junction, e.g. in case one has been
65612 C...shortened by shower, so the last is the largest-energy one.
65613       IF(NJUNC.GE.1) THEN
65614 C...Find systems with exactly one junction.
65615         MJUN1=0
65616         NBEG=NOLD+1
65617         DO 470 I=NOLD+1,N
65618           IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
65619           ELSEIF(K(I,1).EQ.41) THEN
65620             MJUN1=MJUN1+1
65621           ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
65622             MJUN1=0
65623             NBEG=I+1
65624           ELSE
65625             NEND=I
65626 C...Sum up energy-momentum in each junction string.
65627             DO 370 J=1,5
65628               PJU(1,J)=0D0
65629               PJU(2,J)=0D0
65630               PJU(3,J)=0D0
65631   370       CONTINUE
65632             NJU=0
65633             DO 390 I1=NBEG,NEND
65634               IF(K(I1,2).NE.21) THEN
65635                 NJU=NJU+1
65636                 IJUR(NJU)=I1
65637               ENDIF
65638               DO 380 J=1,5
65639                 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
65640   380         CONTINUE
65641   390       CONTINUE
65642 C...Find which of them has highest energy (minus mass) in rest frame.
65643             DO 400 J=1,5
65644               PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65645   400       CONTINUE
65646             PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
65647      &      PJU(4,3)**2))
65648             DO 410 I2=1,3
65649               PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
65650      &        PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
65651   410       CONTINUE
65652             IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
65653 C...Decide how to rearrange so that new last has highest energy.
65654               IF(PJU(1,6).LT.PJU(2,6)) THEN
65655                 IRNG(1,1)=IJUR(1)
65656                 IRNG(1,2)=IJUR(2)-1
65657                 IRNG(2,1)=IJUR(4)
65658                 IRNG(2,2)=IJUR(3)+1
65659                 IRNG(4,1)=IJUR(3)-1
65660                 IRNG(4,2)=IJUR(2)
65661               ELSE
65662                 IRNG(1,1)=IJUR(4)
65663                 IRNG(1,2)=IJUR(3)+1
65664                 IRNG(2,1)=IJUR(2)
65665                 IRNG(2,2)=IJUR(3)-1
65666                 IRNG(4,1)=IJUR(2)-1
65667                 IRNG(4,2)=IJUR(1)
65668               ENDIF
65669               IRNG(3,1)=IJUR(3)
65670               IRNG(3,2)=IJUR(3)
65671 C...Copy in correct order below bottom of current event record.
65672               I2=N
65673               DO 440 II=1,4
65674                 DO 430 I1=IRNG(II,1),IRNG(II,2),
65675      &          ISIGN(1,IRNG(II,2)-IRNG(II,1))
65676                   I2=I2+1
65677                   IF(I2.GE.MSTU(4)-MSTU32-5) THEN
65678                     CALL PYERRM(11,
65679      &              '(PYPREP:) no more memory left in PYJETS')
65680                     MINT(51)=1
65681                     MSTU(24)=1
65682                     RETURN
65683                   ENDIF
65684                   DO 420 J=1,5
65685                     K(I2,J)=K(I1,J)
65686                     P(I2,J)=P(I1,J)
65687                     V(I2,J)=V(I1,J)
65688   420             CONTINUE
65689                   IF(K(I2,1).EQ.1) K(I2,1)=2
65690   430           CONTINUE
65691   440         CONTINUE
65692               K(I2,1)=1
65693 C...Copy back up, overwriting but now in correct order.
65694               DO 460 I1=NBEG,NEND
65695                 I2=I1-NBEG+N+1
65696                 DO 450 J=1,5
65697                   K(I1,J)=K(I2,J)
65698                   P(I1,J)=P(I2,J)
65699                   V(I1,J)=V(I2,J)
65700   450           CONTINUE
65701   460         CONTINUE
65702             ENDIF
65703             MJUN1=0
65704             NBEG=I+1
65705           ENDIF
65706   470   CONTINUE
65707  
65708 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
65709 C...to two q-qbar systems.
65710 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
65711         IF (MSTJ(19).NE.1) THEN
65712           MJUN1  = 0
65713           JJGLUE = 0
65714           NBEG   = NOLD+1
65715 C...Force collapse when MSTJ(19)=2.
65716           IF (MSTJ(19).EQ.2) THEN
65717             DELMJJ = 1D9
65718             DELMQQ = 0D0
65719           ENDIF
65720 C...Find systems with exactly two junctions.
65721           DO 700 I=NOLD+1,N
65722 C...Count junctions
65723             IF (K(I,1).EQ.41) THEN
65724               MJUN1 = MJUN1+1
65725 C...Check for interjunction gluons
65726               IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
65727                 JJGLUE = 1
65728               ENDIF
65729             ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
65730 C...If end of system reached with either zero or one junction, restart
65731 C...with next system.
65732               MJUN1  = 0
65733               JJGLUE = 0
65734               NBEG   = I+1
65735             ELSEIF(K(I,1).EQ.1) THEN
65736 C...If end of system reached with exactly two junctions, compute string
65737 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
65738 C...length measure for the (q-qbar)(q-qbar) topology.
65739               NEND=I
65740 C...Loop down through chain.
65741               ISID=0
65742               DO 480 I1=NBEG,NEND
65743 C...Store string piece division locations in event record
65744                 IF (K(I1,2).NE.21) THEN
65745                   ISID       = ISID+1
65746                   IJCP(ISID) = I1
65747                 ENDIF
65748   480         CONTINUE
65749 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
65750               ISW=0
65751               IF (PYR(0).LT.0.5D0) ISW=1
65752 C...Randomly choose which qqbar string gets the jj gluons.
65753               IGS=1
65754               IF (PYR(0).GT.0.5D0) IGS=2
65755 C...Only compute string lengths when no topology forced.
65756               IF (MSTJ(19).EQ.0) THEN
65757 C...Repeat following for each junction
65758                 DO 570 IJU=1,2
65759 C...Initialize iterative procedure for finding JRF
65760                   IJRFIT=0
65761                   DO 490 IX=1,3
65762                     TJUOLD(IX)=0D0
65763   490             CONTINUE
65764                   TJUOLD(4)=1D0
65765 C...Start iteration. Sum up momenta in string pieces
65766   500             DO 540 IJS=1,3
65767 C...JD=-1 for first junction, +1 for second junction.
65768 C...Find out where piece starts and ends and which direction to go.
65769                     JD=2*IJU-3
65770                     IF (IJS.LE.2) THEN
65771                       IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
65772                       IB = IJCP((IJU-1)*7 - JD*IJS)
65773                     ELSEIF (IJS.EQ.3) THEN
65774                       JD =-JD
65775                       IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
65776                       IB = IJCP((IJU-1)*7 + JD*(IJS+3))
65777                     ENDIF
65778 C...Initialize junction pull 4-vector.
65779                     DO 510 J=1,5
65780                       PUL(IJS,J)=0D0
65781   510               CONTINUE
65782 C...Initialize weight
65783                     PWT = 0D0
65784                     PWTOLD = 0D0
65785 C...Sum up (weighted) momenta along each string piece
65786                     DO 530 ISP=IA,IB,JD
65787 C...If present parton not last in chain
65788                       IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
65789 C...If last parton was a junction, store present weight
65790                         IF (K(ISP-JD,2).EQ.88) THEN
65791                           PWTOLD = PWT
65792 C...If last parton was a quark, reset to stored weight.
65793                         ELSEIF (K(ISP-JD,2).NE.21) THEN
65794                           PWT = PWTOLD
65795                         ENDIF
65796                       ENDIF
65797 C...Skip next parton if weight already large
65798                       IF (PWT.GT.10D0) GOTO 530
65799 C...Compute momentum in TJUOLD frame:
65800                       TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
65801      &                     )*P(ISP,3)
65802                       BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
65803                       DO 520 J=1,3
65804                         TMP=P(ISP,J)+TJUOLD(J)*BFC
65805                         PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
65806   520                 CONTINUE
65807 C...Boosted energy
65808                       TMP=TJUOLD(4)*P(ISP,4)+TDP
65809                       PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
65810 C...Update weight
65811                       PWT=PWT+TMP/PARJ(48)
65812 C...Put |p| rather than m in 5th slot
65813                       PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
65814      &                     +PUL(IJS,3)**2)
65815   530               CONTINUE
65816   540             CONTINUE
65817 C...Compute boost
65818                   IJRFIT=IJRFIT+1
65819                   CALL PYJURF(PUL,T)
65820 C...Combine new boost (T) with old boost (TJUOLD)
65821                   TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
65822                   DO 550 IX=1,3
65823                     TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
65824      &                   ))
65825   550             CONTINUE
65826                   TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
65827      &                 **2)
65828 C...If last boost small, accept JRF, else iterate.
65829 C...Also prevent possibility of infinite loop.
65830                   IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
65831      &                 IJRFIT.LT.MSTJ(18))THEN
65832                     GOTO 500
65833                   ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
65834                     CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
65835                   ENDIF
65836 C...Store final boost, with change of sign since TJJ motion vector.
65837                   DO 560 IX=1,3
65838                     TJJ(IJU,IX)=-TJUOLD(IX)
65839   560             CONTINUE
65840                   TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
65841      &                 +TJJ(IJU,3)**2)
65842   570           CONTINUE
65843 C...String length measure for (q-qbar)(q-qbar) topology.
65844 C...Note only momenta of nearest partons used (since rest of system
65845 C...identical).
65846                 IF (JJGLUE.EQ.0) THEN
65847                   DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
65848      &                 -1,IJCP(5-ISW)+1)
65849                 ELSE
65850 C...Put jj gluons on selected string (IGS selected randomly above).
65851                   IF (IGS.EQ.1) THEN
65852                     DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65853      &                   ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
65854                   ELSE
65855                     DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
65856      &                   *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65857      &                   ,IJCP(5-ISW)+1)
65858                   ENDIF
65859                 ENDIF
65860 C...String length measure for q-q-j-j-q-q topology.
65861                 T1G1=0D0
65862                 T2G2=0D0
65863                 T1T2=0D0
65864                 T1P1=0D0
65865                 T1P2=0D0
65866                 T2P3=0D0
65867                 T2P4=0D0
65868                 ISGN=-1
65869 C...Note only momenta of nearest partons used (since rest of system
65870 C...identical).
65871                 DO 580 IX=1,4
65872                   IF (IX.EQ.4) ISGN=1
65873                   T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
65874                   T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
65875                   T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
65876                   T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
65877                   IF (JJGLUE.EQ.0) THEN
65878 C...Junction motion vector dot product gives length when inter-junction
65879 C...gluons absent.
65880                     T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
65881                   ELSE
65882 C...Junction motion vector dot products with gluon momenta give length
65883 C...when inter-junction gluons present.
65884                     T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
65885                     T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
65886                   ENDIF
65887   580           CONTINUE
65888                 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
65889                 IF (JJGLUE.EQ.0) THEN
65890                   DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
65891                 ELSE
65892                   DELMJJ=DELMJJ*4D0*T1G1*T2G2
65893                 ENDIF
65894               ENDIF
65895 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
65896 C...(Always the case for MSTJ(19)=2 due to initialization above)
65897               IF (DELMJJ.GT.DELMQQ) THEN
65898 C...Put new system at end of event record
65899                 NCOP=N
65900                 DO 650 IST=1,2
65901                   DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
65902                     NCOP=NCOP+1
65903                     DO 590 IX=1,5
65904                       P(NCOP,IX)=P(ICOP,IX)
65905                       K(NCOP,IX)=K(ICOP,IX)
65906   590               CONTINUE
65907   600             CONTINUE
65908                   IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
65909 C...Insert inter-junction gluon string piece (reversed)
65910                     NJJGL=0
65911                     DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
65912                       NJJGL=NJJGL+1
65913                       NCOP=NCOP+1
65914                       DO 610 IX=1,5
65915                         P(NCOP,IX)=P(ICOP,IX)
65916                         K(NCOP,IX)=K(ICOP,IX)
65917   610                 CONTINUE
65918   620               CONTINUE
65919                     ENDIF
65920                   IFC=-2*IST+3
65921                   DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
65922                     NCOP=NCOP+1
65923                     DO 630 IX=1,5
65924                       P(NCOP,IX)=P(ICOP,IX)
65925                       K(NCOP,IX)=K(ICOP,IX)
65926   630               CONTINUE
65927   640             CONTINUE
65928                   K(NCOP,1)=1
65929   650           CONTINUE
65930 C...Copy system back in right order
65931                 DO 670 ICOP=NBEG,NEND-2
65932                   DO 660 IX=1,5
65933                     P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
65934                     K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
65935   660             CONTINUE
65936   670           CONTINUE
65937 C...Shift down rest of event record
65938                 DO 690 ICOP=NEND+1,N
65939                   DO 680 IX=1,5
65940                     P(ICOP-2,IX)=P(ICOP,IX)
65941                     K(ICOP-2,IX)=K(ICOP,IX)
65942   680             CONTINUE
65943   690             CONTINUE
65944 C...Update length of event record.
65945                 N=N-2
65946               ENDIF
65947               MJUN1=0
65948               NBEG=I+1
65949             ENDIF
65950   700     CONTINUE
65951         ENDIF
65952       ENDIF
65953  
65954 C...Done if no checks on small-mass systems.
65955       IF(MSTJ(14).LT.0) RETURN
65956       IF(MSTJ(14).EQ.0) GOTO 1140
65957  
65958 C...Find lowest-mass colour singlet jet system.
65959       NS=N
65960   710 NSIN=N-NS
65961       PDMIN=1D0+PARJ(32)
65962       IC=0
65963       DO 770 I=MAX(1,IP),N
65964         IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
65965         ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
65966           NSIN=NSIN+1
65967           IC=I
65968           DO 720 J=1,4
65969             DPS(J)=P(I,J)
65970   720     CONTINUE
65971           MSTJ(93)=1
65972           DPS(5)=PYMASS(K(I,2))
65973         ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
65974           DO 730 J=1,4
65975             DPS(J)=DPS(J)+P(I,J)
65976   730     CONTINUE
65977           MSTJ(93)=1
65978           DPS(5)=DPS(5)+PYMASS(K(I,2))
65979         ELSEIF(K(I,1).EQ.2) THEN
65980           DO 740 J=1,4
65981             DPS(J)=DPS(J)+P(I,J)
65982   740     CONTINUE
65983         ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65984           DO 750 J=1,4
65985             DPS(J)=DPS(J)+P(I,J)
65986   750     CONTINUE
65987           MSTJ(93)=1
65988           DPS(5)=DPS(5)+PYMASS(K(I,2))
65989           PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
65990      &    DPS(5)
65991           IF(PD.LT.PDMIN) THEN
65992             PDMIN=PD
65993             DO 760 J=1,5
65994               DPC(J)=DPS(J)
65995   760       CONTINUE
65996             IC1=IC
65997             IC2=I
65998           ENDIF
65999           IC=0
66000         ELSE
66001           NSIN=NSIN+1
66002         ENDIF
66003   770 CONTINUE
66004  
66005 C...Done if lowest-mass system above threshold for string frag.
66006       IF(PDMIN.GE.PARJ(32)) GOTO 1140
66007  
66008 C...Fill small-mass system as cluster.
66009       NSAV=N
66010       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
66011       K(N+1,1)=11
66012       K(N+1,2)=91
66013       K(N+1,3)=IC1
66014       P(N+1,1)=DPC(1)
66015       P(N+1,2)=DPC(2)
66016       P(N+1,3)=DPC(3)
66017       P(N+1,4)=DPC(4)
66018       P(N+1,5)=PECM
66019  
66020 C...Set up history, assuming cluster -> 2 hadrons.
66021       NBODY=2
66022       K(N+1,4)=N+2
66023       K(N+1,5)=N+3
66024       K(N+2,1)=1
66025       K(N+3,1)=1
66026       IF(MSTU(16).NE.2) THEN
66027         K(N+2,3)=N+1
66028         K(N+3,3)=N+1
66029       ELSE
66030         K(N+2,3)=IC1
66031         K(N+3,3)=IC2
66032       ENDIF
66033       K(N+2,4)=0
66034       K(N+3,4)=0
66035       K(N+2,5)=0
66036       K(N+3,5)=0
66037       V(N+1,5)=0D0
66038       V(N+2,5)=0D0
66039       V(N+3,5)=0D0
66040  
66041 C...Find total flavour content - complicated by presence of junctions.
66042       NQ=0
66043       NDIQ=0
66044       DO 780 I=IC1,IC2
66045         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
66046           NQ=NQ+1
66047           KFQ(NQ)=K(I,2)
66048           IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
66049         ENDIF
66050   780 CONTINUE
66051  
66052 C...If several diquarks, split up one to give even number of flavours.
66053       IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
66054         I1=3
66055         IF(IABS(KFQ(3)).LT.1000) I1=1
66056         KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
66057         KFQ(I1)=KFQ(I1)/1000
66058         NQ=4
66059         NDIQ=NDIQ-1
66060       ENDIF
66061  
66062 C...If four quark ends, join two to diquark.
66063       IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
66064         I1=1
66065         I2=2
66066         IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
66067         IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
66068         KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
66069         IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
66070         KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
66071      &  100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
66072         KFQ(I2)=KFQ(4)
66073         NQ=3
66074         NDIQ=1
66075       ENDIF
66076  
66077 C...If two quark ends, plus quark or diquark, join quarks to diquark.
66078       IF(NQ.EQ.3) THEN
66079         I1=1
66080         I2=2
66081         IF(IABS(KFQ(I1)).GT.1000) I1=3
66082         IF(IABS(KFQ(I2)).GT.1000) I2=3
66083         KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
66084         IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
66085         KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
66086      &  100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
66087         KFQ(I2)=KFQ(3)
66088         NQ=2
66089         NDIQ=NDIQ+1
66090       ENDIF
66091  
66092 C...Form two particles from flavours of lowest-mass system, if feasible.
66093       NTRY = 0
66094   790 NTRY = NTRY + 1
66095  
66096 C...Open string with two specified endpoint flavours.
66097       IF(NQ.EQ.2) THEN
66098         KC1=PYCOMP(KFQ(1))
66099         KC2=PYCOMP(KFQ(2))
66100         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
66101         KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
66102         KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
66103         IF(KQ1+KQ2.NE.0) GOTO 1140
66104 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
66105   800   K1=KFQ(1)
66106         IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
66107         MSTU(125)=0
66108         CALL PYDCYK(K1,0,KFLN,K(N+2,2))
66109         CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
66110         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
66111  
66112 C...Open string with four specified flavours.
66113       ELSEIF(NQ.EQ.4) THEN
66114         KC1=PYCOMP(KFQ(1))
66115         KC2=PYCOMP(KFQ(2))
66116         KC3=PYCOMP(KFQ(3))
66117         KC4=PYCOMP(KFQ(4))
66118         IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
66119         KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
66120         KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
66121         KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
66122         KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
66123         IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
66124 C...Combine flavours pairwise to form two hadrons.
66125   810   I1=1
66126         I2=2
66127         IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
66128      &  IABS(KFQ(2)).GT.1000)) I2=3
66129         IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
66130      &  IABS(KFQ(3)).GT.1000))) I2=4
66131         I3=3
66132         IF(I2.EQ.3) I3=2
66133         I4=10-I1-I2-I3
66134         CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
66135         CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
66136         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
66137  
66138 C...Closed string.
66139       ELSE
66140         IF(IABS(K(IC2,2)).NE.21) GOTO 1140
66141 C...No room for popcorn mesons in closed string -> 2 hadrons.
66142         MSTU(125)=0
66143   820   CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
66144         CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
66145         CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
66146         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
66147       ENDIF
66148       P(N+2,5)=PYMASS(K(N+2,2))
66149       P(N+3,5)=PYMASS(K(N+3,2))
66150  
66151 C...If it does not work: try again (a number of times), give up (if no
66152 C...place to shuffle momentum or too many flavours), or form one hadron.
66153       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
66154         IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
66155           GOTO 790
66156         ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
66157           GOTO 1140
66158         ELSE
66159           GOTO 890
66160         END IF
66161       END IF
66162  
66163 C...Perform two-particle decay of jet system.
66164 C...First step: find reference axis in decaying system rest frame.
66165 C...(Borrow slot N+2 for temporary direction.)
66166       DO 830 J=1,4
66167         P(N+2,J)=P(IC1,J)
66168   830 CONTINUE
66169       DO 850 I=IC1+1,IC2-1
66170         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
66171      &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
66172           FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
66173           DO 840 J=1,4
66174             P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
66175   840     CONTINUE
66176         ENDIF
66177   850 CONTINUE
66178       CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
66179      &-DPC(3)/DPC(4))
66180       THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
66181       PHI1=PYANGL(P(N+2,1),P(N+2,2))
66182  
66183 C...Second step: generate isotropic/anisotropic decay.
66184       PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
66185      &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
66186   860 UE(3)=PYR(0)
66187       IF(PARJ(21).LE.0.01D0) UE(3)=1D0
66188       PT2=(1D0-UE(3)**2)*PA**2
66189       IF(MSTJ(16).LE.0) THEN
66190         PREV=0.5D0
66191       ELSE
66192         IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
66193         PR1=P(N+2,5)**2+PT2
66194         PR2=P(N+3,5)**2+PT2
66195         ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
66196         PREVCF=PARJ(42)
66197         IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
66198         PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
66199       ENDIF
66200       IF(PYR(0).LT.PREV) UE(3)=-UE(3)
66201       PHI=PARU(2)*PYR(0)
66202       UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66203       UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66204       DO 870 J=1,3
66205         P(N+2,J)=PA*UE(J)
66206         P(N+3,J)=-PA*UE(J)
66207   870 CONTINUE
66208       P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
66209       P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
66210  
66211 C...Third step: move back to event frame and set production vertex.
66212       CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
66213      &DPC(3)/DPC(4))
66214       DO 880 J=1,4
66215         V(N+1,J)=V(IC1,J)
66216         V(N+2,J)=V(IC1,J)
66217         V(N+3,J)=V(IC2,J)
66218   880 CONTINUE
66219       N=N+3
66220       GOTO 1120
66221  
66222 C...Else form one particle, if possible.
66223   890 NBODY=1
66224       K(N+1,5)=N+2
66225       DO 900 J=1,4
66226         V(N+1,J)=V(IC1,J)
66227         V(N+2,J)=V(IC1,J)
66228   900 CONTINUE
66229  
66230 C...Select hadron flavour from available quark flavours.
66231   910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
66232         GOTO 1140
66233       ELSEIF(NQ.EQ.2) THEN
66234         CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
66235       ELSE
66236         KFLN=1+INT((2D0+PARJ(2))*PYR(0))
66237         CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
66238       ENDIF
66239       IF(K(N+2,2).EQ.0) GOTO 910
66240       P(N+2,5)=PYMASS(K(N+2,2))
66241  
66242 C...Use old algorithm for E/p conservation? (EN)
66243       IF (MSTJ(16).LE.0) GOTO 1080
66244  
66245 C...Find the string piece closest to the cluster by a loop
66246 C...over the undecayed partons not in present cluster. (EN)
66247       DGLOMI=1D30
66248       IBEG=0
66249       I0=0
66250       NJUNC=0
66251       DO 940 I1=MAX(1,IP),N-1
66252         IF(K(I1,1).EQ.1) NJUNC=0
66253         IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
66254         IF(K(I1,1).EQ.41) GOTO 940
66255         IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
66256           I0=0
66257         ELSEIF(K(I1,1).EQ.2) THEN
66258           IF(I0.EQ.0) I0=I1
66259           I2=I1
66260   920     I2=I2+1
66261           IF(K(I2,1).EQ.41) GOTO 940
66262           IF(K(I2,1).GT.10) GOTO 920
66263           IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
66264           IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
66265      &    NJUNC.EQ.0) GOTO 940
66266           IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
66267           IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
66268      &    K(I2,1).NE.1)) GOTO 940
66269  
66270 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
66271           DO 930 J=1,3
66272             E1(J)=P(I1,J)/P(I1,4)
66273             E2(J)=P(I2,J)/P(I2,4)
66274             ECL(J)=P(N+1,J)/P(N+1,4)
66275             E3(J)=E2(J)-E1(J)
66276             E4(J)=ECL(J)-E1(J)
66277   930     CONTINUE
66278  
66279 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
66280           E3S=E3(1)**2+E3(2)**2+E3(3)**2
66281           E4S=E4(1)**2+E4(2)**2+E4(3)**2
66282           E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
66283           IF(E34.LE.0D0) THEN
66284             DDMIN=E4S
66285           ELSEIF(E34.LT.E3S) THEN
66286             DDMIN=E4S-E34**2/E3S
66287           ELSE
66288             DDMIN=E4S-2D0*E34+E3S
66289           ENDIF
66290  
66291 C...Is this the smallest so far?
66292           IF(DDMIN.LT.DGLOMI) THEN
66293             DGLOMI=DDMIN
66294             IBEG=I0
66295             IPCS=I1
66296           ENDIF
66297         ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
66298           I0=0
66299         ENDIF
66300   940 CONTINUE
66301  
66302 C... Check if there are any strings to connect to the new gluon. (EN)
66303       IF (IBEG.EQ.0) GOTO 1080
66304  
66305 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
66306       IF (P(N+1,5).GE.P(N+2,5)) THEN
66307  
66308 C...Construct 'gluon' that is needed to put hadron on the mass shell.
66309         FRAC=P(N+2,5)/P(N+1,5)
66310         DO 950 J=1,5
66311           P(N+2,J)=FRAC*P(N+1,J)
66312           PG(J)=(1D0-FRAC)*P(N+1,J)
66313   950   CONTINUE
66314  
66315 C... Copy string with new gluon put in.
66316         N=N+2
66317         I=IBEG-1
66318   960   I=I+1
66319         IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
66320         IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
66321         N=N+1
66322         DO 970 J=1,5
66323           K(N,J)=K(I,J)
66324           P(N,J)=P(I,J)
66325           V(N,J)=V(I,J)
66326   970   CONTINUE
66327         K(I,1)=K(I,1)+10
66328         K(I,4)=N
66329         K(I,5)=N
66330         K(N,3)=I
66331         IF(I.EQ.IPCS) THEN
66332           N=N+1
66333           DO 980 J=1,5
66334             K(N,J)=K(N-1,J)
66335             P(N,J)=PG(J)
66336             V(N,J)=V(N-1,J)
66337   980     CONTINUE
66338           K(N,2)=21
66339           K(N,3)=NSAV+1
66340         ENDIF
66341         IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
66342         GOTO 1120
66343  
66344 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
66345 C...from string piece endpoints.
66346       ELSE
66347  
66348 C...Begin by copying string that should give energy to cluster.
66349         N=N+2
66350         I=IBEG-1
66351   990   I=I+1
66352         IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
66353         IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
66354         N=N+1
66355         DO 1000 J=1,5
66356           K(N,J)=K(I,J)
66357           P(N,J)=P(I,J)
66358           V(N,J)=V(I,J)
66359  1000   CONTINUE
66360         K(I,1)=K(I,1)+10
66361         K(I,4)=N
66362         K(I,5)=N
66363         K(N,3)=I
66364         IF(I.EQ.IPCS) I1=N
66365         IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
66366         I2=I1+1
66367  
66368 C...Set initial Phad.
66369         DO 1010 J=1,4
66370           P(NSAV+2,J)=P(NSAV+1,J)
66371  1010   CONTINUE
66372  
66373 C...Calculate Pg, a part of which will be added to Phad later. (EN)
66374  1020   IF(MSTJ(16).EQ.1) THEN
66375           ALPHA=1D0
66376           BETA=1D0
66377         ELSE
66378           ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
66379           BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
66380         ENDIF
66381         DO 1030 J=1,4
66382           PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
66383  1030   CONTINUE
66384         PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
66385  
66386 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
66387         PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
66388      &  P(NSAV+2,3)**2
66389         PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
66390      &  P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
66391         DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
66392  
66393 C...If all gluon energy eaten, zero it and take a step back.
66394         ITER=0
66395         IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
66396           ITER=1
66397           DO 1040 J=1,4
66398             P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
66399             P(I1,J)=0D0
66400  1040     CONTINUE
66401           P(I1,5)=0D0
66402           K(I1,1)=K(I1,1)+10
66403           I1=I1-1
66404           IF(K(I1,1).EQ.41) ITER=-1
66405         ENDIF
66406         IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
66407           ITER=1
66408           DO 1050 J=1,4
66409             P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
66410             P(I2,J)=0D0
66411  1050     CONTINUE
66412           P(I2,5)=0D0
66413           K(I2,1)=K(I2,1)+10
66414           I2=I2+1
66415           IF(K(I2,1).EQ.41) ITER=-1
66416         ENDIF
66417         IF(ITER.EQ.1) GOTO 1020
66418  
66419 C...If also all endpoint energy eaten, revert to old procedure.
66420         IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
66421      &  (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
66422           DO 1060 I=NSAV+3,N
66423             IM=K(I,3)
66424             K(IM,1)=K(IM,1)-10
66425             K(IM,4)=0
66426             K(IM,5)=0
66427  1060     CONTINUE
66428           N=NSAV
66429           GOTO 1080
66430         ENDIF
66431  
66432 C... Construct the collapsed hadron and modified string partons.
66433         DO 1070 J=1,4
66434           P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
66435           P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
66436           P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
66437  1070   CONTINUE
66438           P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
66439           P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
66440  
66441 C...Finished with string collapse in new scheme.
66442         GOTO 1120
66443       ENDIF
66444  
66445 C... Use old algorithm; by choice or when in trouble.
66446  1080 CONTINUE
66447 C...Find parton/particle which combines to largest extra mass.
66448       IR=0
66449       HA=0D0
66450       HSM=0D0
66451       DO 1100 MCOMB=1,3
66452         IF(IR.NE.0) GOTO 1100
66453         DO 1090 I=MAX(1,IP),N
66454           IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
66455      &    .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
66456           IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
66457           IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
66458           IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
66459           IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
66460      &    GOTO 1090
66461           HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
66462           HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
66463           IF(HSR.GT.HSM) THEN
66464             IR=I
66465             HA=HCR
66466             HSM=HSR
66467           ENDIF
66468  1090   CONTINUE
66469  1100 CONTINUE
66470  
66471 C...Shuffle energy and momentum to put new particle on mass shell.
66472       IF(IR.NE.0) THEN
66473         HB=PECM**2+HA
66474         HC=P(N+2,5)**2+HA
66475         HD=P(IR,5)**2+HA
66476         HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
66477      &  (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
66478         HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
66479         DO 1110 J=1,4
66480           P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
66481           P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
66482  1110   CONTINUE
66483         N=N+2
66484       ELSE
66485         CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
66486         RETURN
66487       ENDIF
66488  
66489 C...Mark collapsed system and store daughter pointers. Iterate.
66490  1120 DO 1130 I=IC1,IC2
66491         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
66492      &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
66493           K(I,1)=K(I,1)+10
66494           IF(MSTU(16).NE.2) THEN
66495             K(I,4)=NSAV+1
66496             K(I,5)=NSAV+1
66497           ELSE
66498             K(I,4)=NSAV+2
66499             K(I,5)=NSAV+1+NBODY
66500           ENDIF
66501         ENDIF
66502         IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
66503  1130 CONTINUE
66504       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
66505  
66506 C...Check flavours and invariant masses in parton systems.
66507  1140 NP=0
66508       KFN=0
66509       KQS=0
66510       NJU=0
66511       DO 1150 J=1,5
66512         DPS(J)=0D0
66513  1150 CONTINUE
66514       DO 1180 I=MAX(1,IP),N
66515         IF(K(I,1).EQ.41) NJU=NJU+1
66516         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
66517         KC=PYCOMP(K(I,2))
66518         IF(KC.EQ.0) GOTO 1180
66519         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
66520         IF(KQ.EQ.0) GOTO 1180
66521         NP=NP+1
66522         IF(KQ.NE.2) THEN
66523           KFN=KFN+1
66524           KQS=KQS+KQ
66525           MSTJ(93)=1
66526           DPS(5)=DPS(5)+PYMASS(K(I,2))
66527         ENDIF
66528         DO 1160 J=1,4
66529           DPS(J)=DPS(J)+P(I,J)
66530  1160   CONTINUE
66531         IF(K(I,1).EQ.1) THEN
66532           NFERR=0
66533           IF(NJU.EQ.0.AND.NP.NE.1) THEN
66534             IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
66535           ELSEIF(NJU.EQ.1) THEN
66536             IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
66537           ELSEIF(NJU.EQ.2) THEN
66538             IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
66539           ELSEIF(NJU.GE.3) THEN
66540             NFERR=1
66541           ENDIF
66542           IF(NFERR.EQ.1) THEN
66543             CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
66544             MINT(51)=1
66545             RETURN
66546           ENDIF
66547           IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
66548      &    (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
66549      &    '(PYPREP:) too small mass in jet system')
66550           NP=0
66551           KFN=0
66552           KQS=0
66553           NJU=0
66554           DO 1170 J=1,5
66555             DPS(J)=0D0
66556  1170     CONTINUE
66557         ENDIF
66558  1180 CONTINUE
66559  
66560       RETURN
66561       END
66562  
66563 C*********************************************************************
66564  
66565 C...PYSTRF
66566 C...Handles the fragmentation of an arbitrary colour singlet
66567 C...jet system according to the Lund string fragmentation model.
66568  
66569       SUBROUTINE PYSTRF(IP)
66570  
66571 C...Double precision and integer declarations.
66572       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66573       IMPLICIT INTEGER(I-N)
66574       INTEGER PYK,PYCHGE,PYCOMP
66575 C...Commonblocks.
66576       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66577       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66578       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66579       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
66580 C...Local arrays. All MOPS variables ends with MO
66581       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
66582      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
66583      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
66584      &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
66585      &PBST(3,5),TJUOLD(5)
66586  
66587 C...Function: four-product of two vectors.
66588       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)
66589       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
66590      &DP(I,3)*DP(J,3)
66591  
66592 C...Reset counters.
66593       MSTJ(91)=0
66594       NSAV=N
66595       MSTU90=MSTU(90)
66596       NP=0
66597       KQSUM=0
66598       DO 100 J=1,5
66599         DPS(J)=0D0
66600   100 CONTINUE
66601       MJU(1)=0
66602       MJU(2)=0
66603       NTRYFN=0
66604       IJUORI(1)=0
66605       IJUORI(2)=0
66606  
66607 C...Identify parton system.
66608       I=IP-1
66609   110 I=I+1
66610       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
66611         CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
66612         IF(MSTU(21).GE.1) RETURN
66613       ENDIF
66614       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
66615       KC=PYCOMP(K(I,2))
66616       IF(KC.EQ.0) GOTO 110
66617       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
66618       IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
66619       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
66620         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66621         IF(MSTU(21).GE.1) RETURN
66622       ENDIF
66623  
66624 C...Take copy of partons to be considered. Check flavour sum.
66625       NP=NP+1
66626       DO 120 J=1,5
66627         K(N+NP,J)=K(I,J)
66628         P(N+NP,J)=P(I,J)
66629         IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
66630   120 CONTINUE
66631       DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66632       K(N+NP,3)=I
66633       IF(KQ.NE.2) KQSUM=KQSUM+KQ
66634       IF(K(I,1).EQ.41) THEN
66635         IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
66636           MJU(1)=N+NP
66637           IJUORI(1)=I
66638         ELSE
66639           MJU(2)=N+NP
66640           IJUORI(2)=I
66641         ENDIF
66642       ENDIF
66643       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
66644       IF(MOD(KQSUM,3).NE.0) THEN
66645         CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
66646         IF(MSTU(21).GE.1) RETURN
66647       ENDIF
66648       IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
66649  
66650 C...Boost copied system to CM frame (for better numerical precision).
66651       IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
66652         MBST=0
66653         MSTU(33)=1
66654         CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
66655      &  -DPS(3)/DPS(4))
66656       ELSE
66657         MBST=1
66658         HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
66659         DO 130 I=N+1,N+NP
66660           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
66661           IF(P(I,3).GT.0D0) THEN
66662             HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
66663             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
66664             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
66665           ELSE
66666             HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
66667             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
66668             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
66669           ENDIF
66670   130   CONTINUE
66671       ENDIF
66672  
66673 C...Search for very nearby partons that may be recombined.
66674       NTRYR=0
66675       NTRYWR=0
66676       PARU12=PARU(12)
66677       PARU13=PARU(13)
66678       MJU(3)=MJU(1)
66679       MJU(4)=MJU(2)
66680       NR=NP
66681       NRMIN=2
66682       IF(MJU(1).GT.0) NRMIN=NRMIN+2
66683       IF(MJU(2).GT.0) NRMIN=NRMIN+2
66684   140 IF(NR.GT.NRMIN) THEN
66685         PDRMIN=2D0*PARU12
66686         DO 150 I=N+1,N+NR
66687           IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
66688           I1=I+1
66689           IF(I.EQ.N+NR) I1=N+1
66690           IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
66691           IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
66692      &    GOTO 150
66693           IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
66694      &    GOTO 150
66695           PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
66696      &    P(I1,2)**2+P(I1,3)**2))
66697           PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
66698           PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
66699           IF(PDR.LT.PDRMIN) THEN
66700             IR=I
66701             PDRMIN=PDR
66702           ENDIF
66703   150   CONTINUE
66704  
66705 C...Recombine very nearby partons to avoid machine precision problems.
66706         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
66707           DO 160 J=1,4
66708             P(N+1,J)=P(N+1,J)+P(N+NR,J)
66709   160     CONTINUE
66710           P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
66711      &    P(N+1,3)**2))
66712           NR=NR-1
66713           GOTO 140
66714         ELSEIF(PDRMIN.LT.PARU12) THEN
66715           DO 170 J=1,4
66716             P(IR,J)=P(IR,J)+P(IR+1,J)
66717   170     CONTINUE
66718           P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
66719      &    P(IR,3)**2))
66720           IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
66721           DO 190 I=IR+1,N+NR-1
66722             K(I,1)=K(I+1,1)
66723             K(I,2)=K(I+1,2)
66724             DO 180 J=1,5
66725               P(I,J)=P(I+1,J)
66726   180       CONTINUE
66727   190     CONTINUE
66728           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
66729           NR=NR-1
66730           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
66731           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
66732           GOTO 140
66733         ENDIF
66734       ENDIF
66735       NTRYR=NTRYR+1
66736  
66737 C...Reset particle counter. Skip ahead if no junctions are present;
66738 C...this is usually the case!
66739       NRS=MAX(5*NR+11,NP)
66740       NTRY=0
66741   200 NTRY=NTRY+1
66742       IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66743         PARU12=4D0*PARU12
66744         PARU13=2D0*PARU13
66745         GOTO 140
66746       ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
66747         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66748         IF(MSTU(21).EQ.2) MSTU(90)=0
66749         IF(MSTU(21).GE.1) RETURN
66750       ENDIF
66751       I=N+NRS
66752       MSTU(90)=MSTU90
66753       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
66754       IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
66755      &     ' junction strings not handled by MSTJ(12)>3 options')
66756       DO 640 JT=1,2
66757         NJS(JT)=0
66758         IF(MJU(JT).EQ.0) GOTO 640
66759         JS=3-2*JT
66760  
66761 C++SKANDS
66762 C...Find and sum up momentum on three sides of junction.
66763 C...Begin with previous boost = zero.
66764         IJRFIT=0
66765         DO 210 IX=1,3
66766           TJUOLD(IX)=0D0
66767   210   CONTINUE
66768 C...Prevent IJU (specifically IJU(5)) from containing junk below
66769         DO 215 IU=1,6
66770           IJU(IU)=0
66771  215    CONTINUE
66772         TJUOLD(4)=1D0
66773   220   IU=0
66774 C...Beginning and end of string system in event record.
66775         I1BEG=N+1+(JT-1)*(NR-1)
66776         I1END=N+NR+(JT-1)*(1-NR)
66777 C...Look for junction string piece end points
66778         DO 230 I1=I1BEG,I1END,JS
66779           IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
66780 C...Store junction string piece end points.
66781 C                 1-junction systems        2-junction systems
66782 C           IU :  1     2     3   4     1     2   3     4   5     6
66783 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
66784             IU=IU+1
66785             IJU(IU)=I1
66786           ENDIF
66787 C...Sum over momenta, from junction outwards.
66788   230   CONTINUE
66789         DO 280 IU=1,3
66790           PWT=0D0
66791 C...Initialize junction drag and string piece 4-vectors.
66792           DO 240 J=1,5
66793             PBST(IU,J)=0D0
66794             PJU(IU,J)=0D0
66795   240     CONTINUE
66796 C...First two branches. Inwards out means opposite direction to JS.
66797 C...(JS is 1 for JT=1, -1 for JT=2)
66798           IF (IU.LT.3) THEN
66799             I1A=IJU(IU+1)-JS
66800             I1B=IJU(IU)
66801             IDIR=-JS
66802 C...Last branch (gq or gjgqgq). Direction now reversed.
66803           ELSE
66804             I1A=IJU(IU)+JS
66805             I1B=I1END
66806             IDIR=JS
66807           ENDIF
66808           DO 270 I1=I1A,I1B,IDIR
66809 C...Sum up momentum directions with exponential suppression
66810 C...for use in finding junction rest frame below.
66811             IF (K(I1,2).EQ.88) THEN
66812 C...gjgqgq type system encountered. Use current PWT as start
66813 C...for both strings.
66814               PWTOLD=PWT
66815             ELSE
66816               IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
66817 C...Sum up string piece (boosted) 4-momenta.
66818               DO 250 J=1,4
66819                 PJU(IU,J)=PJU(IU,J)+P(I1,J)
66820   250         CONTINUE
66821 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
66822 C...boost is zero, see above). Skip parton if suppression factor large.
66823               IF (PWT.GT.10D0) GOTO 270
66824 C...Compute momentum in current frame:
66825               TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
66826               BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
66827               DO 260 J=1,3
66828                 PTMP=P(I1,J)+TJUOLD(J)*BFC
66829                 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
66830   260         CONTINUE
66831 C...Boosted energy
66832               PTMP=TJUOLD(4)*P(I1,4)+TDP
66833               PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
66834               PWT=PWT+PTMP/PARJ(48)
66835             ENDIF
66836   270     CONTINUE
66837 C...Put |p| rather than m in 5th slot.
66838           PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
66839           PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
66840   280   CONTINUE
66841  
66842 C...Calculate boost from present frame to next JRF candidate.
66843         IJRFIT=IJRFIT+1
66844         CALL PYJURF(PBST,TJU)
66845  
66846 C...After some iterations do not take full step in new direction.
66847         IF(IJRFIT.GT.5) THEN
66848           REDUCE=0.8D0**(IJRFIT-5)
66849           TJU(1)=REDUCE*TJU(1)
66850           TJU(2)=REDUCE*TJU(2)
66851           TJU(3)=REDUCE*TJU(3)
66852           TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66853         ENDIF
66854  
66855 C...Combine new boost (TJU) with old boost (TJUOLD)
66856         TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
66857         DO 290 IX=1,3
66858           TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
66859   290   CONTINUE
66860         TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
66861  
66862 C...If last boost small, accept JRF, else iterate.
66863 C...Also prevent possibility of infinite loop.
66864         IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
66865      &  IJRFIT.LT.MSTJ(18)) THEN
66866           GOTO 220
66867         ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
66868           CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
66869         ENDIF
66870  
66871 C...Now store total boost in TJU and change perception.
66872 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
66873 C...TJU = junction motion vector in string CM, so the sign changes.
66874         DO 300 J=1,3
66875           TJU(J)=-TJUOLD(J)
66876   300   CONTINUE
66877         TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66878  
66879 C--SKANDS
66880  
66881 C...Calculate string piece energies in junction rest frame.
66882         DO 310 IU=1,3
66883           PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
66884      &    TJU(3)*PJU(IU,3)
66885           PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
66886      &    TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
66887   310   CONTINUE
66888  
66889 C...Start preparing for fragmentation of two strings from junction.
66890         ISTA=I
66891         NTRYER=0
66892   320   NTRYER=NTRYER+1
66893         MSTU(90)=MSTU90
66894         I=ISTA
66895         DO 620 IU=1,2
66896           NS=IABS(IJU(IU+1)-IJU(IU))
66897  
66898 C...Junction strings: find longitudinal string directions.
66899           DO 350 IS=1,NS
66900             IS1=IJU(IU)+JS*(IS-1)
66901             IS2=IJU(IU)+JS*IS
66902             DO 330 J=1,5
66903               DP(1,J)=0.5D0*P(IS1,J)
66904               IF(IS.EQ.1) DP(1,J)=P(IS1,J)
66905               DP(2,J)=0.5D0*P(IS2,J)
66906               IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
66907      &        (PJU(IU,5)/PBST(IU,5))
66908   330       CONTINUE
66909             IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
66910      &      PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
66911             DP(3,5)=DFOUR(1,1)
66912             DP(4,5)=DFOUR(2,2)
66913             DHKC=DFOUR(1,2)
66914             IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
66915               DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66916               DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66917               DP(3,5)=0D0
66918               DP(4,5)=0D0
66919               DHKC=DFOUR(1,2)
66920             ENDIF
66921             DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66922             DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66923             DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66924             IN1=N+NR+4*IS-3
66925             P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66926             DO 340 J=1,4
66927               P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66928               P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66929   340       CONTINUE
66930   350     CONTINUE
66931  
66932 C...Junction strings: initialize flavour, momentum and starting pos.
66933           ISAV=I
66934           MSTU91=MSTU(90)
66935   360     NTRY=NTRY+1
66936           IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66937             PARU12=4D0*PARU12
66938             PARU13=2D0*PARU13
66939             GOTO 140
66940           ELSEIF(NTRY.GT.100) THEN
66941             CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66942             IF(MSTU(21).EQ.2) MSTU(90)=0
66943             IF(MSTU(21).GE.1) RETURN
66944           ENDIF
66945           I=ISAV
66946           MSTU(90)=MSTU91
66947           IRANKJ=0
66948           IE(1)=K(N+1+(JT/2)*(NP-1),3)
66949           IF (MOD(JT+IU,2).NE.0) THEN
66950             IE(1)=K(IJU(IU),3)
66951             IF (NP-NR.NE.0) THEN
66952 C...If gluons have disappeared. Original IJU must be used.
66953               IT=IP
66954               NE=1
66955   370         IT=IT+1
66956               IF (K(IT,2).NE.21) THEN
66957                 NE=NE+1
66958               ENDIF
66959               IF (NE.EQ.IU+4*(JT-1)) THEN
66960                 IE(1)=IT
66961               ELSEIF (IT.LE.IP+NP) THEN
66962                 GOTO 370
66963               ELSE
66964                 CALL PYERRM(14,'(PYSTRF:) '//
66965      &               'Original IJU could not be reconstructed!')
66966               ENDIF
66967             ENDIF
66968           ENDIF
66969           IN(4)=N+NR+1
66970           IN(5)=IN(4)+1
66971           IN(6)=N+NR+4*NS+1
66972           DO 390 JQ=1,2
66973             DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
66974               P(IN1,1)=2-JQ
66975               P(IN1,2)=JQ-1
66976               P(IN1,3)=1D0
66977   380       CONTINUE
66978   390     CONTINUE
66979           KFL(1)=K(IJU(IU),2)
66980           PX(1)=0D0
66981           PY(1)=0D0
66982           GAM(1)=0D0
66983           DO 400 J=1,5
66984             PJU(IU+3,J)=0D0
66985   400     CONTINUE
66986  
66987 C...Junction strings: find initial transverse directions.
66988           DO 410 J=1,4
66989             DP(1,J)=P(IN(4),J)
66990             DP(2,J)=P(IN(4)+1,J)
66991             DP(3,J)=0D0
66992             DP(4,J)=0D0
66993   410     CONTINUE
66994           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66995           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66996           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66997           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66998           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66999           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
67000           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
67001           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
67002           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
67003           DHC12=DFOUR(1,2)
67004           DHCX1=DFOUR(3,1)/DHC12
67005           DHCX2=DFOUR(3,2)/DHC12
67006           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
67007           DHCY1=DFOUR(4,1)/DHC12
67008           DHCY2=DFOUR(4,2)/DHC12
67009           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
67010           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
67011           DO 420 J=1,4
67012             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
67013             P(IN(6),J)=DP(3,J)
67014             P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
67015      &      DHCYX*DP(3,J))
67016   420     CONTINUE
67017  
67018 C...Junction strings: produce new particle, origin.
67019   430     I=I+1
67020           IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
67021             CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
67022             IF(MSTU(21).GE.1) RETURN
67023           ENDIF
67024           IRANKJ=IRANKJ+1
67025           K(I,1)=1
67026           K(I,3)=IE(1)
67027           K(I,4)=0
67028           K(I,5)=0
67029  
67030 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
67031   440     CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
67032           IF(K(I,2).EQ.0) GOTO 360
67033           IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
67034      &    IABS(KFL(3)).GT.10) THEN
67035             IF(PYR(0).GT.PARJ(19)) GOTO 440
67036           ENDIF
67037           P(I,5)=PYMASS(K(I,2))
67038           CALL PYPTDI(KFL(1),PX(3),PY(3))
67039           PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
67040           CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
67041           IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
67042      &    MSTU(90).LT.8) THEN
67043             MSTU(90)=MSTU(90)+1
67044             MSTU(90+MSTU(90))=I
67045             PARU(90+MSTU(90))=Z
67046           ENDIF
67047           GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
67048           DO 450 J=1,3
67049             IN(J)=IN(3+J)
67050   450     CONTINUE
67051  
67052 C...Junction strings: stepping within 'low' string region.
67053           IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
67054      &    P(IN(1),5)**2.GE.PR(1)) THEN
67055             P(IN(1)+2,4)=Z*P(IN(1)+2,3)
67056             P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
67057             DO 460 J=1,4
67058               P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
67059   460       CONTINUE
67060             GOTO 560
67061 C...Has used up energy of junction string, i.e. no more hadrons in it.
67062           ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
67063             DO 470 J=1,5
67064               P(I,J)=0D0
67065   470       CONTINUE
67066             GOTO 600
67067 C...Stepping from 'low' string region
67068           ELSEIF(IN(1)+1.EQ.IN(2)) THEN
67069             P(IN(2)+2,4)=P(IN(2)+2,3)
67070             P(IN(2)+2,1)=1D0
67071             IN(2)=IN(2)+4
67072             IF(IN(2).GT.N+NR+4*NS) GOTO 360
67073             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67074               P(IN(1)+2,4)=P(IN(1)+2,3)
67075               P(IN(1)+2,1)=0D0
67076               IN(1)=IN(1)+4
67077             ENDIF
67078           ENDIF
67079  
67080 C...Junction strings: find new transverse directions.
67081   480     IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
67082      &    IN(1).GT.IN(2)) GOTO 360
67083           IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
67084             DO 490 J=1,4
67085               DP(1,J)=P(IN(1),J)
67086               DP(2,J)=P(IN(2),J)
67087               DP(3,J)=0D0
67088               DP(4,J)=0D0
67089   490       CONTINUE
67090             DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
67091             DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
67092             DHC12=DFOUR(1,2)
67093             IF(DHC12.LE.1D-2) THEN
67094               P(IN(1)+2,4)=P(IN(1)+2,3)
67095               P(IN(1)+2,1)=0D0
67096               IN(1)=IN(1)+4
67097               GOTO 480
67098             ENDIF
67099             IN(3)=N+NR+4*NS+5
67100             DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
67101             DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
67102             DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
67103             IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
67104             IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
67105             IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
67106             IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
67107             DHCX1=DFOUR(3,1)/DHC12
67108             DHCX2=DFOUR(3,2)/DHC12
67109             DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
67110             DHCY1=DFOUR(4,1)/DHC12
67111             DHCY2=DFOUR(4,2)/DHC12
67112             DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
67113             DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
67114             DO 500 J=1,4
67115               DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
67116               P(IN(3),J)=DP(3,J)
67117               P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
67118      &        DHCYX*DP(3,J))
67119   500       CONTINUE
67120 C...Express pT with respect to new axes, if sensible.
67121             PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
67122             PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
67123             IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
67124               PX(3)=PXP
67125               PY(3)=PYP
67126             ENDIF
67127           ENDIF
67128  
67129 C...Junction strings: sum up known four-momentum, coefficients for m2.
67130           DO 530 J=1,4
67131             DHG(J)=0D0
67132             P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
67133      &      PY(3)*P(IN(3)+1,J)
67134             DO 510 IN1=IN(4),IN(1)-4,4
67135               P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
67136   510       CONTINUE
67137             DO 520 IN2=IN(5),IN(2)-4,4
67138               P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
67139   520       CONTINUE
67140   530     CONTINUE
67141           DHM(1)=FOUR(I,I)
67142           DHM(2)=2D0*FOUR(I,IN(1))
67143           DHM(3)=2D0*FOUR(I,IN(2))
67144           DHM(4)=2D0*FOUR(IN(1),IN(2))
67145  
67146 C...Junction strings: find coefficients for Gamma expression.
67147           DO 550 IN2=IN(1)+1,IN(2),4
67148             DO 540 IN1=IN(1),IN2-1,4
67149               DHC=2D0*FOUR(IN1,IN2)
67150               DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
67151               IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
67152               IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
67153               IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
67154   540       CONTINUE
67155   550     CONTINUE
67156  
67157 C...Junction strings: solve (m2, Gamma) equation system for energies.
67158           DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
67159           IF(ABS(DHS1).LT.1D-4) GOTO 360
67160           DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
67161      &    (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
67162           DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
67163           P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
67164      &    ABS(DHS1)-DHS2/DHS1)
67165           IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
67166           P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
67167      &    (DHM(2)+DHM(4)*P(IN(2)+2,4))
67168  
67169 C...Junction strings: step to new region if necessary.
67170           IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
67171             P(IN(2)+2,4)=P(IN(2)+2,3)
67172             P(IN(2)+2,1)=1D0
67173             IN(2)=IN(2)+4
67174             IF(IN(2).GT.N+NR+4*NS) GOTO 360
67175             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67176               P(IN(1)+2,4)=P(IN(1)+2,3)
67177               P(IN(1)+2,1)=0D0
67178               IN(1)=IN(1)+4
67179             ENDIF
67180             GOTO 480
67181           ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
67182             P(IN(1)+2,4)=P(IN(1)+2,3)
67183             P(IN(1)+2,1)=0D0
67184             IN(1)=IN(1)+4
67185             GOTO 480
67186           ENDIF
67187  
67188 C...Junction strings: particle four-momentum, remainder, loop back.
67189   560     DO 570 J=1,4
67190             P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
67191      &      P(IN(2)+2,4)*P(IN(2),J)
67192             PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
67193   570     CONTINUE
67194           IF(P(I,4).LT.P(I,5)) GOTO 360
67195           PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
67196      &    TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
67197           IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
67198             KFL(1)=-KFL(3)
67199             PX(1)=-PX(3)
67200             PY(1)=-PY(3)
67201             GAM(1)=GAM(3)
67202             IF(IN(3).NE.IN(6)) THEN
67203               DO 580 J=1,4
67204                 P(IN(6),J)=P(IN(3),J)
67205                 P(IN(6)+1,J)=P(IN(3)+1,J)
67206   580         CONTINUE
67207             ENDIF
67208             DO 590 JQ=1,2
67209               IN(3+JQ)=IN(JQ)
67210               P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
67211               P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
67212   590       CONTINUE
67213             GOTO 430
67214           ENDIF
67215  
67216 C...Junction strings: save quantities left after each string.
67217           IF(IABS(KFL(1)).GT.10) GOTO 360
67218   600     I=I-1
67219           IF(MSTU(90+MSTU(90)).EQ.I+1) MSTU(90)=MSTU(90)-1 
67220           KFJH(IU)=KFL(1)
67221           DO 610 J=1,4
67222             PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
67223   610     CONTINUE
67224  
67225 C...Junction strings: loopback if much unused energy in both strings.
67226           PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
67227      &    TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
67228           EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
67229   620   CONTINUE
67230         IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
67231      &  EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
67232      &  EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
67233      &  .AND.NTRYER.LT.10) GOTO 320
67234  
67235 C...Junction strings: put together to new effective string endpoint.
67236         NJS(JT)=I-ISTA
67237         KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
67238         IF(KFJH(1).EQ.KFJH(2)) KFLS=3
67239         KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
67240      &  100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
67241         DO 630 J=1,4
67242           PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
67243           PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
67244   630   CONTINUE
67245         PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
67246      &  PJS(JT,3)**2))
67247         PJS(JT+2,5)=0D0
67248   640 CONTINUE
67249  
67250 C...Open versus closed strings. Choose breakup region for latter.
67251   650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
67252         NS=MJU(2)-MJU(1)
67253         NB=MJU(1)-N
67254       ELSEIF(MJU(1).NE.0) THEN
67255         NS=N+NR-MJU(1)
67256         NB=MJU(1)-N
67257       ELSEIF(MJU(2).NE.0) THEN
67258         NS=MJU(2)-N
67259         NB=1
67260       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
67261         NS=NR-1
67262         NB=1
67263       ELSE
67264         NS=NR+1
67265         W2SUM=0D0
67266         DO 660 IS=1,NR
67267           P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
67268           W2SUM=W2SUM+P(N+NR+IS,1)
67269   660   CONTINUE
67270         W2RAN=PYR(0)*W2SUM
67271         NB=0
67272   670   NB=NB+1
67273         W2SUM=W2SUM-P(N+NR+NB,1)
67274         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
67275       ENDIF
67276  
67277 C...Find longitudinal string directions (i.e. lightlike four-vectors).
67278       DO 700 IS=1,NS
67279         IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
67280         IS2=N+IS+NB-NR*((IS+NB-1)/NR)
67281         DO 680 J=1,5
67282           DP(1,J)=P(IS1,J)
67283           IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
67284           IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
67285           DP(2,J)=P(IS2,J)
67286           IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
67287           IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
67288   680   CONTINUE
67289         IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
67290      &  DP(1,2)**2-DP(1,3)**2))
67291         IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
67292      &  DP(2,2)**2-DP(2,3)**2))
67293         DP(3,5)=DFOUR(1,1)
67294         DP(4,5)=DFOUR(2,2)
67295         DHKC=DFOUR(1,2)
67296         IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
67297         DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
67298         DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
67299         DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
67300         IN1=N+NR+4*IS-3
67301         P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
67302         DO 690 J=1,4
67303           P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
67304           P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
67305   690   CONTINUE
67306   700 CONTINUE
67307  
67308 C...Begin initialization: sum up energy, set starting position.
67309       ISAV=I
67310       MSTU91=MSTU(90)
67311   710 NTRY=NTRY+1
67312       IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
67313         PARU12=4D0*PARU12
67314         PARU13=2D0*PARU13
67315         GOTO 140
67316       ELSEIF(NTRY.GT.100) THEN
67317         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
67318         IF(MSTU(21).EQ.2) MSTU(90)=0
67319         IF(MSTU(21).GE.1) RETURN
67320       ENDIF
67321       I=ISAV
67322       MSTU(90)=MSTU91
67323       DO 730 J=1,4
67324         P(N+NRS,J)=0D0
67325         DO 720 IS=1,NR
67326           P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
67327   720   CONTINUE
67328   730 CONTINUE
67329       DO 750 JT=1,2
67330         IRANK(JT)=0
67331         IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
67332         IF(NS.GT.NR) IRANK(JT)=1
67333         IBARRK(JT)=0
67334         IE(JT)=K(N+1+(JT/2)*(NP-1),3)
67335         IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
67336         IN(3*JT+2)=IN(3*JT+1)+1
67337         IN(3*JT+3)=N+NR+4*NS+2*JT-1
67338         DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
67339           P(IN1,1)=2-JT
67340           P(IN1,2)=JT-1
67341           P(IN1,3)=1D0
67342   740   CONTINUE
67343   750 CONTINUE
67344  
67345 C.. MOPS variables and switches
67346       NRVMO=0
67347       XBMO=1D0
67348       MSTU(121)=0
67349       MSTU(122)=0
67350  
67351 C...Initialize flavour and pT variables for open string.
67352       IF(NS.LT.NR) THEN
67353         PX(1)=0D0
67354         PY(1)=0D0
67355         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
67356         PX(2)=-PX(1)
67357         PY(2)=-PY(1)
67358         DO 760 JT=1,2
67359           KFL(JT)=K(IE(JT),2)
67360           IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
67361           IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
67362           MSTJ(93)=1
67363           PMQ(JT)=PYMASS(KFL(JT))
67364           GAM(JT)=0D0
67365   760   CONTINUE
67366  
67367 C...Closed string: random initial breakup flavour, pT and vertex.
67368       ELSE
67369         KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67370         IBMO=0
67371   770   CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
67372 C.. Closed string: first vertex diq attempt => enforced second
67373 C.. vertex diq
67374         IF(IABS(KFL(1)).GT.10)THEN
67375            IBMO=1
67376            MSTU(121)=0
67377            GOTO 770
67378         ENDIF
67379         IF(IBMO.EQ.1) MSTU(121)=-1
67380         KFL(2)=-KFL(1)
67381         CALL PYPTDI(KFL(1),PX(1),PY(1))
67382         PX(2)=-PX(1)
67383         PY(2)=-PY(1)
67384         PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
67385   780   CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
67386         ZR=PR3/(Z*P(N+NR+1,5)**2)
67387         IF(ZR.GE.1D0) GOTO 780
67388         DO 790 JT=1,2
67389           MSTJ(93)=1
67390           PMQ(JT)=PYMASS(KFL(JT))
67391           GAM(JT)=PR3*(1D0-Z)/Z
67392           IN1=N+NR+3+4*(JT/2)*(NS-1)
67393           P(IN1,JT)=1D0-Z
67394           P(IN1,3-JT)=JT-1
67395           P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
67396           P(IN1+1,JT)=ZR
67397           P(IN1+1,3-JT)=2-JT
67398           P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
67399   790   CONTINUE
67400       ENDIF
67401 C.. MOPS variables
67402       DO 800 JT=1,2
67403          XTMO(JT)=1D0
67404          PM2QMO(JT)=PMQ(JT)**2
67405          IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
67406   800 CONTINUE
67407  
67408 C...Find initial transverse directions (i.e. spacelike four-vectors).
67409       DO 840 JT=1,2
67410         IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
67411           IN1=IN(3*JT+1)
67412           IN3=IN(3*JT+3)
67413           DO 810 J=1,4
67414             DP(1,J)=P(IN1,J)
67415             DP(2,J)=P(IN1+1,J)
67416             DP(3,J)=0D0
67417             DP(4,J)=0D0
67418   810     CONTINUE
67419           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
67420           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
67421           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
67422           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
67423           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
67424           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
67425           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
67426           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
67427           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
67428           DHC12=DFOUR(1,2)
67429           DHCX1=DFOUR(3,1)/DHC12
67430           DHCX2=DFOUR(3,2)/DHC12
67431           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
67432           DHCY1=DFOUR(4,1)/DHC12
67433           DHCY2=DFOUR(4,2)/DHC12
67434           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
67435           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
67436           DO 820 J=1,4
67437             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
67438             P(IN3,J)=DP(3,J)
67439             P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
67440      &      DHCYX*DP(3,J))
67441   820     CONTINUE
67442         ELSE
67443           DO 830 J=1,4
67444             P(IN3+2,J)=P(IN3,J)
67445             P(IN3+3,J)=P(IN3+1,J)
67446   830     CONTINUE
67447         ENDIF
67448   840 CONTINUE
67449  
67450 C...Remove energy used up in junction string fragmentation.
67451       IF(MJU(1)+MJU(2).GT.0) THEN
67452         DO 860 JT=1,2
67453           IF(NJS(JT).EQ.0) GOTO 860
67454           DO 850 J=1,4
67455             P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
67456   850     CONTINUE
67457   860   CONTINUE
67458         PARJST=PARJ(33)
67459         IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
67460         WMIN=PARJST+PMQ(1)+PMQ(2)
67461         WREM2=FOUR(N+NRS,N+NRS)
67462         IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
67463           NTRYWR=NTRYWR+1
67464           IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
67465           GOTO 140
67466         ENDIF
67467       ENDIF
67468  
67469 C...Produce new particle: side, origin.
67470   870 I=I+1
67471       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
67472         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
67473         IF(MSTU(21).GE.1) RETURN
67474       ENDIF
67475 C.. New side priority for popcorn systems
67476       IF(MSTU(121).LE.0)THEN
67477          JT=1.5D0+PYR(0)
67478          IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
67479          IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
67480       ENDIF
67481       JR=3-JT
67482       JS=3-2*JT
67483       IRANK(JT)=IRANK(JT)+1
67484       K(I,1)=1
67485       K(I,4)=0
67486       K(I,5)=0
67487  
67488 C...Generate flavour, hadron and pT.
67489   880 K(I,3)=IE(JT)
67490       CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
67491       IF(K(I,2).EQ.0) GOTO 710
67492       MU90MO=MSTU(90)
67493       IF(MSTU(121).EQ.-1) GOTO 910
67494       IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
67495      &IABS(KFL(3)).GT.10) THEN
67496         IF(PYR(0).GT.PARJ(19)) GOTO 880
67497       ENDIF
67498       IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67499      &K(I,3)=IJUORI(JT)
67500       P(I,5)=PYMASS(K(I,2))
67501       CALL PYPTDI(KFL(JT),PX(3),PY(3))
67502       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
67503  
67504 C...Final hadrons for small invariant mass.
67505       MSTJ(93)=1
67506       PMQ(3)=PYMASS(KFL(3))
67507       PARJST=PARJ(33)
67508       IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
67509       WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
67510       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
67511      &WMIN-0.5D0*PARJ(36)*PMQ(3)
67512       WREM2=FOUR(N+NRS,N+NRS)
67513       IF(WREM2.LT.0.10D0) GOTO 710
67514       IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
67515      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
67516  
67517 C...Choose z, which gives Gamma. Shift z for heavy flavours.
67518       CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
67519       IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
67520      &MSTU(90).LT.8) THEN
67521         MSTU(90)=MSTU(90)+1
67522         MSTU(90+MSTU(90))=I
67523         PARU(90+MSTU(90))=Z
67524       ENDIF
67525       KFL1A=IABS(KFL(1))
67526       KFL2A=IABS(KFL(2))
67527       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
67528      &MOD(KFL2A/1000,10)).GE.4) THEN
67529         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67530         PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
67531         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
67532         PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67533         IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
67534       ENDIF
67535       GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
67536  
67537 C.. MOPS baryon model modification
67538       XTMO3=(1D0-Z)*XTMO(JT)
67539       IF(IABS(KFL(3)).LE.10) NRVMO=0
67540       IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
67541          GTSTMO=1D0
67542          PTSTMO=1D0
67543          RTSTMO=PYR(0)
67544          IF(IABS(KFL(JT)).LE.10)THEN
67545             XBMO=MIN(XTMO3,1D0-(2D-10))
67546             GBMO=GAM(3)
67547             PMMO=0D0
67548             PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
67549             GTSTMO=1D0-PARF(192)**PGMO
67550          ELSE
67551             IF(IRANK(JT).EQ.1) THEN
67552                GBMO=GAM(JT)
67553                PMMO=0D0
67554                XBMO=1D0
67555             ENDIF
67556             IF(XBMO.LT.1D0-(1D-10))THEN
67557                PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
67558                GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
67559                PGMO=PGNMO
67560             ENDIF
67561             IF(MSTJ(12).GE.5)THEN
67562                PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
67563                PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
67564                PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
67565                PMMO=PMNMO
67566             ENDIF
67567          ENDIF
67568  
67569 C.. MOPS Accepting popcorn system hadron.
67570          IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
67571             IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
67572                NRVMO=I-N-NR
67573                IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
67574                   CALL PYERRM(11,
67575      &                 '(PYSTRF:) no more memory left in PYJETS')
67576                   IF(MSTU(21).GE.1) RETURN
67577                ENDIF
67578                IMO=I
67579                KFLMO=KFL(JT)
67580                PMQMO=PMQ(JT)
67581                PXMO=PX(JT)
67582                PYMO=PY(JT)
67583                GAMMO=GAM(JT)
67584                IRMO=IRANK(JT)
67585                XMO=XTMO(JT)
67586                DO 900 J=1,9
67587                   IF(J.LE.5) THEN
67588                      DO 890 LINE=1,I-N-NR
67589                         P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
67590                         K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
67591   890                CONTINUE
67592                   ENDIF
67593                   INMO(J)=IN(J)
67594   900          CONTINUE
67595             ENDIF
67596          ELSE
67597 C..Reject popcorn system, flag=-1 if enforcing new one
67598             MSTU(121)=-1
67599             IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
67600          ENDIF
67601       ENDIF
67602  
67603  
67604 C..Lift restoring string outside MOPS block
67605   910 IF(MSTU(121).LT.0) THEN
67606          IF(MSTU(121).EQ.-2) MSTU(121)=0
67607          MSTU(90)=MU90MO
67608          NRVMO=0
67609          IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
67610          I=IMO
67611          KFL(JT)=KFLMO
67612          PMQ(JT)=PMQMO
67613          PX(JT)=PXMO
67614          PY(JT)=PYMO
67615          GAM(JT)=GAMMO
67616          IRANK(JT)=IRMO
67617          XTMO(JT)=XMO
67618          DO 930 J=1,9
67619             IF(J.LE.5) THEN
67620                DO 920 LINE=1,I-N-NR
67621                   P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
67622                   K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
67623   920          CONTINUE
67624             ENDIF
67625             IN(J)=INMO(J)
67626   930    CONTINUE
67627          GOTO 880
67628       ENDIF
67629       XTMO(JT)=XTMO3
67630 C.. MOPS end of modification
67631  
67632       DO 940 J=1,3
67633         IN(J)=IN(3*JT+J)
67634   940 CONTINUE
67635  
67636 C...Stepping within or from 'low' string region easy.
67637       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
67638      &P(IN(1),5)**2.GE.PR(JT)) THEN
67639         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
67640         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
67641         DO 950 J=1,4
67642           P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
67643   950   CONTINUE
67644         GOTO 1040
67645       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
67646         P(IN(JR)+2,4)=P(IN(JR)+2,3)
67647         P(IN(JR)+2,JT)=1D0
67648         IN(JR)=IN(JR)+4*JS
67649         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
67650         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67651           P(IN(JT)+2,4)=P(IN(JT)+2,3)
67652           P(IN(JT)+2,JT)=0D0
67653           IN(JT)=IN(JT)+4*JS
67654         ENDIF
67655       ENDIF
67656  
67657 C...Find new transverse directions (i.e. spacelike string vectors).
67658   960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
67659      &IN(1).GT.IN(2)) GOTO 710
67660       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
67661         DO 970 J=1,4
67662           DP(1,J)=P(IN(1),J)
67663           DP(2,J)=P(IN(2),J)
67664           DP(3,J)=0D0
67665           DP(4,J)=0D0
67666   970   CONTINUE
67667         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
67668         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
67669         DHC12=DFOUR(1,2)
67670         IF(DHC12.LE.1D-2) THEN
67671           P(IN(JT)+2,4)=P(IN(JT)+2,3)
67672           P(IN(JT)+2,JT)=0D0
67673           IN(JT)=IN(JT)+4*JS
67674           GOTO 960
67675         ENDIF
67676         IN(3)=N+NR+4*NS+5
67677         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
67678         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
67679         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
67680         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
67681         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
67682         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
67683         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
67684         DHCX1=DFOUR(3,1)/DHC12
67685         DHCX2=DFOUR(3,2)/DHC12
67686         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
67687         DHCY1=DFOUR(4,1)/DHC12
67688         DHCY2=DFOUR(4,2)/DHC12
67689         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
67690         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
67691         DO 980 J=1,4
67692           DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
67693           P(IN(3),J)=DP(3,J)
67694           P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
67695      &    DHCYX*DP(3,J))
67696   980   CONTINUE
67697 C...Express pT with respect to new axes, if sensible.
67698         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
67699      &  FOUR(IN(3*JT+3)+1,IN(3)))
67700         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
67701      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
67702         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
67703           PX(3)=PXP
67704           PY(3)=PYP
67705         ENDIF
67706       ENDIF
67707  
67708 C...Sum up known four-momentum. Gives coefficients for m2 expression.
67709       DO 1010 J=1,4
67710         DHG(J)=0D0
67711         P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
67712      &  PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
67713         DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
67714           P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
67715   990   CONTINUE
67716         DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
67717           P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
67718  1000   CONTINUE
67719  1010 CONTINUE
67720       DHM(1)=FOUR(I,I)
67721       DHM(2)=2D0*FOUR(I,IN(1))
67722       DHM(3)=2D0*FOUR(I,IN(2))
67723       DHM(4)=2D0*FOUR(IN(1),IN(2))
67724  
67725 C...Find coefficients for Gamma expression.
67726       DO 1030 IN2=IN(1)+1,IN(2),4
67727         DO 1020 IN1=IN(1),IN2-1,4
67728           DHC=2D0*FOUR(IN1,IN2)
67729           DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
67730           IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
67731           IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
67732           IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
67733  1020   CONTINUE
67734  1030 CONTINUE
67735  
67736 C...Solve (m2, Gamma) equation system for energies taken.
67737       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
67738       IF(ABS(DHS1).LT.1D-4) GOTO 710
67739       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
67740      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
67741       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
67742       P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
67743      &ABS(DHS1)-DHS2/DHS1)
67744       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
67745       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
67746      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
67747  
67748 C...Step to new region if necessary.
67749       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
67750         P(IN(JR)+2,4)=P(IN(JR)+2,3)
67751         P(IN(JR)+2,JT)=1D0
67752         IN(JR)=IN(JR)+4*JS
67753         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
67754         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67755           P(IN(JT)+2,4)=P(IN(JT)+2,3)
67756           P(IN(JT)+2,JT)=0D0
67757           IN(JT)=IN(JT)+4*JS
67758         ENDIF
67759         GOTO 960
67760       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
67761         P(IN(JT)+2,4)=P(IN(JT)+2,3)
67762         P(IN(JT)+2,JT)=0D0
67763         IN(JT)=IN(JT)+4*JS
67764         GOTO 960
67765       ENDIF
67766  
67767 C...Four-momentum of particle. Remaining quantities. Loop back.
67768  1040 DO 1050 J=1,4
67769         P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
67770         P(N+NRS,J)=P(N+NRS,J)-P(I,J)
67771  1050 CONTINUE
67772       IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
67773      &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
67774      &GOTO 200
67775       IF(P(I,4).LT.P(I,5)) GOTO 710
67776       KFL(JT)=-KFL(3)
67777       PMQ(JT)=PMQ(3)
67778       PX(JT)=-PX(3)
67779       PY(JT)=-PY(3)
67780       GAM(JT)=GAM(3)
67781       IF(IN(3).NE.IN(3*JT+3)) THEN
67782         DO 1060 J=1,4
67783           P(IN(3*JT+3),J)=P(IN(3),J)
67784           P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
67785  1060   CONTINUE
67786       ENDIF
67787       DO 1070 JQ=1,2
67788         IN(3*JT+JQ)=IN(JQ)
67789         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
67790         P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
67791  1070 CONTINUE
67792       IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67793      &IBARRK(JT)=0
67794       GOTO 870
67795  
67796 C...Final hadron: side, flavour, hadron, mass.
67797  1080 I=I+1
67798       K(I,1)=1
67799       K(I,3)=IE(JR)
67800       K(I,4)=0
67801       K(I,5)=0
67802       CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
67803       IF(K(I,2).EQ.0) GOTO 710
67804       IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
67805      &IBARRK(JT)=0
67806       IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67807      &K(I,3)=IJUORI(JT)
67808       IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67809      &K(I,3)=IJUORI(JR)
67810       P(I,5)=PYMASS(K(I,2))
67811       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67812  
67813 C...Final two hadrons: find common setup of four-vectors.
67814       JQ=1
67815       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
67816      &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
67817       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
67818       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
67819       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
67820       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
67821         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
67822         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
67823         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
67824      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
67825       ENDIF
67826  
67827 C...Solve kinematics for final two hadrons, if possible.
67828       WREM2=2D0*DHR1*DHR2*DHC12
67829       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
67830       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
67831       IF(FD.GE.1D0) GOTO 710
67832       FA=WREM2+PR(JT)-PR(JR)
67833       FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
67834       PREVCF=PARJ(42)
67835       IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
67836       PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
67837       FB=SIGN(FB,JS*(PYR(0)-PREV))
67838       KFL1A=IABS(KFL(1))
67839       KFL2A=IABS(KFL(2))
67840       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
67841      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
67842      &4D0*WREM2*PR(JT))),DBLE(JS))
67843       DO 1090 J=1,4
67844         P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
67845      &  P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
67846      &  DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
67847         P(I,J)=P(N+NRS,J)-P(I-1,J)
67848  1090 CONTINUE
67849       IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
67850       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
67851       DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
67852       IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
67853         NTRYFN=NTRYFN+1
67854         IF(NTRYFN.LT.100) GOTO 140
67855         CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
67856       ENDIF
67857  
67858 C...Mark jets as fragmented and give daughter pointers.
67859       N=I-NRS+1
67860       DO 1100 I=NSAV+1,NSAV+NP
67861         IM=K(I,3)
67862         K(IM,1)=K(IM,1)+10
67863         IF(MSTU(16).NE.2) THEN
67864           K(IM,4)=NSAV+1
67865           K(IM,5)=NSAV+1
67866         ELSE
67867           K(IM,4)=NSAV+2
67868           K(IM,5)=N
67869         ENDIF
67870  1100 CONTINUE
67871  
67872 C...Document string system. Move up particles.
67873       NSAV=NSAV+1
67874       K(NSAV,1)=11
67875       K(NSAV,2)=92
67876       K(NSAV,3)=IP
67877       K(NSAV,4)=NSAV+1
67878       K(NSAV,5)=N
67879       DO 1110 J=1,4
67880         P(NSAV,J)=DPS(J)
67881         V(NSAV,J)=V(IP,J)
67882  1110 CONTINUE
67883       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67884       V(NSAV,5)=0D0
67885       DO 1130 I=NSAV+1,N
67886         DO 1120 J=1,5
67887           K(I,J)=K(I+NRS-1,J)
67888           P(I,J)=P(I+NRS-1,J)
67889           V(I,J)=0D0
67890  1120   CONTINUE
67891  1130 CONTINUE
67892       MSTU91=MSTU(90)
67893       DO 1140 IZ=MSTU90+1,MSTU91
67894         MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
67895         PARU9T(IZ)=PARU(90+IZ)
67896  1140 CONTINUE
67897       MSTU(90)=MSTU90
67898  
67899 C...Order particles in rank along the chain. Update mother pointer.
67900       DO 1160 I=NSAV+1,N
67901         DO 1150 J=1,5
67902           K(I-NSAV+N,J)=K(I,J)
67903           P(I-NSAV+N,J)=P(I,J)
67904  1150   CONTINUE
67905  1160 CONTINUE
67906       I1=NSAV
67907       DO 1190 I=N+1,2*N-NSAV
67908         IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
67909         I1=I1+1
67910         DO 1170 J=1,5
67911           K(I1,J)=K(I,J)
67912           P(I1,J)=P(I,J)
67913  1170   CONTINUE
67914         IF(MSTU(16).NE.2) K(I1,3)=NSAV
67915         DO 1180 IZ=MSTU90+1,MSTU91
67916           IF(MSTU9T(IZ).EQ.I) THEN
67917             MSTU(90)=MSTU(90)+1
67918             MSTU(90+MSTU(90))=I1
67919             PARU(90+MSTU(90))=PARU9T(IZ)
67920           ENDIF
67921  1180   CONTINUE
67922  1190 CONTINUE
67923       DO 1220 I=2*N-NSAV,N+1,-1
67924         IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
67925         I1=I1+1
67926         DO 1200 J=1,5
67927           K(I1,J)=K(I,J)
67928           P(I1,J)=P(I,J)
67929  1200   CONTINUE
67930         IF(MSTU(16).NE.2) K(I1,3)=NSAV
67931         DO 1210 IZ=MSTU90+1,MSTU91
67932           IF(MSTU9T(IZ).EQ.I) THEN
67933             MSTU(90)=MSTU(90)+1
67934             MSTU(90+MSTU(90))=I1
67935             PARU(90+MSTU(90))=PARU9T(IZ)
67936           ENDIF
67937  1210   CONTINUE
67938  1220 CONTINUE
67939  
67940 C...Boost back particle system. Set production vertices.
67941       IF(MBST.EQ.0) THEN
67942         MSTU(33)=1
67943         CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
67944      &  DPS(3)/DPS(4))
67945       ELSE
67946         DO 1230 I=NSAV+1,N
67947           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
67948           IF(P(I,3).GT.0D0) THEN
67949             HHPEZ=(P(I,4)+P(I,3))*HHBZ
67950             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
67951             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67952           ELSE
67953             HHPEZ=(P(I,4)-P(I,3))/HHBZ
67954             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
67955             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67956           ENDIF
67957  1230   CONTINUE
67958       ENDIF
67959       DO 1250 I=NSAV+1,N
67960         DO 1240 J=1,4
67961           V(I,J)=V(IP,J)
67962  1240   CONTINUE
67963  1250 CONTINUE
67964  
67965       RETURN
67966       END
67967  
67968 C*********************************************************************
67969  
67970 C...PYJURF
67971 C...From three given input vectors in PJU the boost VJU from
67972 C...the "lab frame" to the junction rest frame is constructed.
67973  
67974       SUBROUTINE PYJURF(PJU,VJU)
67975  
67976 C...Double precision and integer declarations.
67977       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67978       IMPLICIT INTEGER(I-N)
67979  
67980 C...Input, output and local arrays.
67981       DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
67982       DATA TWOPI/6.283186D0/
67983  
67984 C...Calculate masses and other invariants.
67985       DO 100 J=1,4
67986         PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
67987   100 CONTINUE
67988       PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
67989       PSUM(5)=SQRT(PSUM2)
67990       DO 120 I=1,3
67991         DO 110 J=1,3
67992           A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
67993      &    PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
67994   110   CONTINUE
67995   120 CONTINUE
67996  
67997 C...Pick I to be most massive parton and J to be the one closest to I.
67998       ITRY=0
67999       I=1
68000       IF(A(2,2).GT.A(1,1)) I=2
68001       IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
68002   130 ITRY=ITRY+1
68003       J=1+MOD(I,3)
68004       K=1+MOD(J,3)
68005       IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
68006         K=1+MOD(I,3)
68007         J=1+MOD(K,3)
68008       ENDIF
68009       PMI2=A(I,I)
68010       PMJ2=A(J,J)
68011       PMK2=A(K,K)
68012       AIJ=A(I,J)
68013       AIK=A(I,K)
68014       AJK=A(J,K)
68015  
68016 C...Trivial find new parton energies if all three partons are massless.
68017       IF(PMI2.LT.1D-4) THEN
68018         PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
68019         PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
68020         PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
68021  
68022 C...Else find momentum range for parton I and values at extremes.
68023       ELSE
68024         PAIMIN=0D0
68025         PEIMIN=SQRT(PMI2)
68026         PEJMIN=AIJ/PEIMIN
68027         PEKMIN=AIK/PEIMIN
68028         PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
68029         PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
68030         FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
68031         PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
68032         IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
68033         PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
68034         HI=PEIMAX**2-0.25D0*PAIMAX**2
68035         PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
68036      &  0.5D0*PAIMAX*AIJ)/HI
68037         PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
68038      &  0.5D0*PAIMAX*AIK)/HI
68039         PEJMAX=SQRT(PAJMAX**2+PMJ2)
68040         PEKMAX=SQRT(PAKMAX**2+PMK2)
68041         FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
68042  
68043 C...If unexpected values at upper endpoint then pick another parton.
68044         IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
68045           I1=1+MOD(I,3)
68046           IF(A(I1,I1).GE.1D-4) THEN
68047             I=I1
68048             GOTO 130
68049           ENDIF
68050           ITRY=ITRY+1
68051           I1=1+MOD(I,3)
68052           IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
68053             I=I1
68054             GOTO 130
68055           ENDIF
68056         ENDIF
68057  
68058 C..Start binary + linear search to find solution inside range.
68059         ITER=0
68060         ITMIN=0
68061         ITMAX=0
68062         PAI=0.5D0*(PAIMIN+PAIMAX)
68063   140   ITER=ITER+1
68064  
68065 C...Derive momentum of other two partons and distance to root.
68066         PEI=SQRT(PAI**2+PMI2)
68067         HI=PEI**2-0.25D0*PAI**2
68068         PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
68069         PEJ=SQRT(PAJ**2+PMJ2)
68070         PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
68071         PEK=SQRT(PAK**2+PMK2)
68072         FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
68073  
68074 C...Pick next I momentum to explore, hopefully closer to root.
68075         IF(FNOW.GT.0D0) THEN
68076           PAIMIN=PAI
68077           FMIN=FNOW
68078           ITMIN=ITMIN+1
68079         ELSE
68080           PAIMAX=PAI
68081           FMAX=FNOW
68082           ITMAX=ITMAX+1
68083         ENDIF
68084         IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
68085      &  THEN
68086           PAI=0.5D0*(PAIMIN+PAIMAX)
68087           GOTO 140
68088         ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
68089      &  ABS(FNOW).GT.1D-12*PSUM2) THEN
68090           PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
68091           GOTO 140
68092         ENDIF
68093       ENDIF
68094  
68095 C...Now know energies in junction rest frame.
68096       PENEW(I)=PEI
68097       PENEW(J)=PEJ
68098       PENEW(K)=PEK
68099  
68100 C...Boost (copy of) partons to their rest frame.
68101       VXCM=-PSUM(1)/PSUM(5)
68102       VYCM=-PSUM(2)/PSUM(5)
68103       VZCM=-PSUM(3)/PSUM(5)
68104       GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
68105       DO 150 I=1,3
68106         FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
68107         FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
68108         PCM(I,1)=PJU(I,1)+FAC2*VXCM
68109         PCM(I,2)=PJU(I,2)+FAC2*VYCM
68110         PCM(I,3)=PJU(I,3)+FAC2*VZCM
68111         PCM(I,4)=PJU(I,4)*GAMCM+FAC1
68112         PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
68113   150 CONTINUE
68114  
68115 C...Construct difference vectors and boost to junction rest frame.
68116       DO 160 J=1,3
68117         PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
68118         PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
68119   160 CONTINUE
68120       PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
68121       PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
68122       PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
68123       PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
68124       PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
68125       C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
68126       C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
68127       VXJU=C4*PCM(4,1)+C5*PCM(5,1)
68128       VYJU=C4*PCM(4,2)+C5*PCM(5,2)
68129       VZJU=C4*PCM(4,3)+C5*PCM(5,3)
68130       GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
68131  
68132 C...Add two boosts, giving final result.
68133       FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
68134       VJU(1)=VXJU+FCM*VXCM
68135       VJU(2)=VYJU+FCM*VYCM
68136       VJU(3)=VZJU+FCM*VZCM
68137       VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
68138       VJU(5)=1D0
68139  
68140 C...In case of error in reconstruction: revert to CM frame of system.
68141       CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
68142      &(PCM(1,5)*PCM(2,5))
68143       CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
68144      &(PCM(1,5)*PCM(3,5))
68145       CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
68146      &(PCM(2,5)*PCM(3,5))
68147       ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
68148       ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
68149       DO 170 I=1,3
68150         FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
68151         FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
68152         PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
68153         PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
68154         PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
68155         PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
68156         PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
68157   170 CONTINUE
68158       CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
68159      &(PCM(1,5)*PCM(2,5))
68160       CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
68161      &(PCM(1,5)*PCM(3,5))
68162       CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
68163      &(PCM(2,5)*PCM(3,5))
68164       ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
68165       ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
68166       IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
68167         VJU(1)=VXCM
68168         VJU(2)=VYCM
68169         VJU(3)=VZCM
68170         VJU(4)=GAMCM
68171       ENDIF
68172  
68173       RETURN
68174       END
68175  
68176 C*********************************************************************
68177  
68178 C...PYINDF
68179 C...Handles the fragmentation of a jet system (or a single
68180 C...jet) according to independent fragmentation models.
68181  
68182       SUBROUTINE PYINDF(IP)
68183  
68184 C...Double precision and integer declarations.
68185       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68186       IMPLICIT INTEGER(I-N)
68187       INTEGER PYK,PYCHGE,PYCOMP
68188 C...Commonblocks.
68189       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68190       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68191       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68192       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
68193 C...Local arrays.
68194       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
68195      &KFLO(2),PXO(2),PYO(2),WO(2)
68196  
68197 C.. MOPS error message
68198       IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
68199      &' are not treated as expected in independent fragmentation')
68200  
68201 C...Reset counters. Identify parton system and take copy. Check flavour.
68202       NSAV=N
68203       MSTU90=MSTU(90)
68204       NJET=0
68205       KQSUM=0
68206       DO 100 J=1,5
68207         DPS(J)=0D0
68208   100 CONTINUE
68209       I=IP-1
68210   110 I=I+1
68211       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
68212         CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
68213         IF(MSTU(21).GE.1) RETURN
68214       ENDIF
68215       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
68216       KC=PYCOMP(K(I,2))
68217       IF(KC.EQ.0) GOTO 110
68218       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
68219       IF(KQ.EQ.0) GOTO 110
68220       NJET=NJET+1
68221       IF(KQ.NE.2) KQSUM=KQSUM+KQ
68222       DO 120 J=1,5
68223         K(NSAV+NJET,J)=K(I,J)
68224         P(NSAV+NJET,J)=P(I,J)
68225         DPS(J)=DPS(J)+P(I,J)
68226   120 CONTINUE
68227       K(NSAV+NJET,3)=I
68228       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
68229      &K(I+1,1).EQ.2)) GOTO 110
68230       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
68231         CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
68232         IF(MSTU(21).GE.1) RETURN
68233       ENDIF
68234  
68235 C...Boost copied system to CM frame. Find CM energy and sum flavours.
68236       IF(NJET.NE.1) THEN
68237         MSTU(33)=1
68238         CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
68239      &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
68240       ENDIF
68241       PECM=0D0
68242       DO 130 J=1,3
68243         NFI(J)=0
68244   130 CONTINUE
68245       DO 140 I=NSAV+1,NSAV+NJET
68246         PECM=PECM+P(I,4)
68247         KFA=IABS(K(I,2))
68248         IF(KFA.LE.3) THEN
68249           NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
68250         ELSEIF(KFA.GT.1000) THEN
68251           KFLA=MOD(KFA/1000,10)
68252           KFLB=MOD(KFA/100,10)
68253           IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
68254           IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
68255         ENDIF
68256   140 CONTINUE
68257  
68258 C...Loop over attempts made. Reset counters.
68259       NTRY=0
68260   150 NTRY=NTRY+1
68261       IF(NTRY.GT.200) THEN
68262         CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
68263         IF(MSTU(21).GE.1) RETURN
68264       ENDIF
68265       N=NSAV+NJET
68266       MSTU(90)=MSTU90
68267       DO 160 J=1,3
68268         NFL(J)=NFI(J)
68269         IFET(J)=0
68270         KFLF(J)=0
68271   160 CONTINUE
68272  
68273 C...Loop over jets to be fragmented.
68274       DO 230 IP1=NSAV+1,NSAV+NJET
68275         MSTJ(91)=0
68276         NSAV1=N
68277         MSTU91=MSTU(90)
68278  
68279 C...Initial flavour and momentum values. Jet along +z axis.
68280         KFLH=IABS(K(IP1,2))
68281         IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
68282         KFLO(2)=0
68283         WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
68284  
68285 C...Initial values for quark or diquark jet.
68286   170   IF(IABS(K(IP1,2)).NE.21) THEN
68287           NSTR=1
68288           KFLO(1)=K(IP1,2)
68289           CALL PYPTDI(0,PXO(1),PYO(1))
68290           WO(1)=WF
68291  
68292 C...Initial values for gluon treated like random quark jet.
68293         ELSEIF(MSTJ(2).LE.2) THEN
68294           NSTR=1
68295           IF(MSTJ(2).EQ.2) MSTJ(91)=1
68296           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
68297           CALL PYPTDI(0,PXO(1),PYO(1))
68298           WO(1)=WF
68299  
68300 C...Initial values for gluon treated like quark-antiquark jet pair,
68301 C...sharing energy according to Altarelli-Parisi splitting function.
68302         ELSE
68303           NSTR=2
68304           IF(MSTJ(2).EQ.4) MSTJ(91)=1
68305           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
68306           KFLO(2)=-KFLO(1)
68307           CALL PYPTDI(0,PXO(1),PYO(1))
68308           PXO(2)=-PXO(1)
68309           PYO(2)=-PYO(1)
68310           WO(1)=WF*PYR(0)**(1D0/3D0)
68311           WO(2)=WF-WO(1)
68312         ENDIF
68313  
68314 C...Initial values for rank, flavour, pT and W+.
68315         DO 220 ISTR=1,NSTR
68316   180     I=N
68317           MSTU(90)=MSTU91
68318           IRANK=0
68319           KFL1=KFLO(ISTR)
68320           PX1=PXO(ISTR)
68321           PY1=PYO(ISTR)
68322           W=WO(ISTR)
68323  
68324 C...New hadron. Generate flavour and hadron species.
68325   190     I=I+1
68326           IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
68327             CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
68328             IF(MSTU(21).GE.1) RETURN
68329           ENDIF
68330           IRANK=IRANK+1
68331           K(I,1)=1
68332           K(I,3)=IP1
68333           K(I,4)=0
68334           K(I,5)=0
68335   200     CALL PYKFDI(KFL1,0,KFL2,K(I,2))
68336           IF(K(I,2).EQ.0) GOTO 180
68337           IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
68338             IF(PYR(0).GT.PARJ(19)) GOTO 200
68339           ENDIF
68340  
68341 C...Find hadron mass. Generate four-momentum.
68342           P(I,5)=PYMASS(K(I,2))
68343           CALL PYPTDI(KFL1,PX2,PY2)
68344           P(I,1)=PX1+PX2
68345           P(I,2)=PY1+PY2
68346           PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
68347           CALL PYZDIS(KFL1,KFL2,PR,Z)
68348           MZSAV=0
68349           IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
68350             MZSAV=1
68351             MSTU(90)=MSTU(90)+1
68352             MSTU(90+MSTU(90))=I
68353             PARU(90+MSTU(90))=Z
68354           ENDIF
68355           P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
68356           P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
68357           IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
68358      &    P(I,3).LE.0.001D0) THEN
68359             IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
68360             P(I,3)=0.0001D0
68361             P(I,4)=SQRT(PR)
68362             Z=P(I,4)/W
68363           ENDIF
68364  
68365 C...Remaining flavour and momentum.
68366           KFL1=-KFL2
68367           PX1=-PX2
68368           PY1=-PY2
68369           W=(1D0-Z)*W
68370           DO 210 J=1,5
68371             V(I,J)=0D0
68372   210     CONTINUE
68373  
68374 C...Check if pL acceptable. Go back for new hadron if enough energy.
68375           IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
68376             I=I-1
68377             IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
68378           ENDIF
68379           IF(W.GT.PARJ(31)) GOTO 190
68380           N=I
68381   220   CONTINUE
68382         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
68383         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
68384  
68385 C...Rotate jet to new direction.
68386         THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
68387         PHI=PYANGL(P(IP1,1),P(IP1,2))
68388         MSTU(33)=1
68389         CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
68390         K(K(IP1,3),4)=NSAV1+1
68391         K(K(IP1,3),5)=N
68392  
68393 C...End of jet generation loop. Skip conservation in some cases.
68394   230 CONTINUE
68395       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
68396       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
68397  
68398 C...Subtract off produced hadron flavours, finished if zero.
68399       DO 240 I=NSAV+NJET+1,N
68400         KFA=IABS(K(I,2))
68401         KFLA=MOD(KFA/1000,10)
68402         KFLB=MOD(KFA/100,10)
68403         KFLC=MOD(KFA/10,10)
68404         IF(KFLA.EQ.0) THEN
68405           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
68406           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
68407         ELSE
68408           IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
68409           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
68410           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
68411         ENDIF
68412   240 CONTINUE
68413       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
68414      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
68415       IF(NREQ.EQ.0) GOTO 320
68416  
68417 C...Take away flavour of low-momentum particles until enough freedom.
68418       NREM=0
68419   250 IREM=0
68420       P2MIN=PECM**2
68421       DO 260 I=NSAV+NJET+1,N
68422         P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
68423         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
68424         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
68425   260 CONTINUE
68426       IF(IREM.EQ.0) GOTO 150
68427       K(IREM,1)=7
68428       KFA=IABS(K(IREM,2))
68429       KFLA=MOD(KFA/1000,10)
68430       KFLB=MOD(KFA/100,10)
68431       KFLC=MOD(KFA/10,10)
68432       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
68433       IF(K(IREM,1).EQ.8) GOTO 250
68434       IF(KFLA.EQ.0) THEN
68435         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
68436         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
68437         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
68438       ELSE
68439         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
68440         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
68441         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
68442       ENDIF
68443       NREM=NREM+1
68444       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
68445      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
68446       IF(NREQ.GT.NREM) GOTO 250
68447       DO 270 I=NSAV+NJET+1,N
68448         IF(K(I,1).EQ.8) K(I,1)=1
68449   270 CONTINUE
68450  
68451 C...Find combination of existing and new flavours for hadron.
68452   280 NFET=2
68453       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
68454       IF(NREQ.LT.NREM) NFET=1
68455       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
68456       DO 290 J=1,NFET
68457         IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
68458         KFLF(J)=ISIGN(1,NFL(1))
68459         IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
68460         IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
68461   290 CONTINUE
68462       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
68463      &GOTO 280
68464       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
68465      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
68466      &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
68467       IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
68468       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
68469       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
68470       IF(NFET.LE.2) KFLF(3)=0
68471       IF(KFLF(3).NE.0) THEN
68472         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
68473      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
68474         IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
68475      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
68476       ELSE
68477         KFLFC=KFLF(1)
68478       ENDIF
68479       CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
68480       IF(KF.EQ.0) GOTO 280
68481       DO 300 J=1,MAX(2,NFET)
68482         NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
68483   300 CONTINUE
68484  
68485 C...Store hadron at random among free positions.
68486       NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
68487       DO 310 I=NSAV+NJET+1,N
68488         IF(K(I,1).EQ.7) NPOS=NPOS-1
68489         IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
68490         K(I,1)=1
68491         K(I,2)=KF
68492         P(I,5)=PYMASS(K(I,2))
68493         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
68494   310 CONTINUE
68495       NREM=NREM-1
68496       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
68497      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
68498       IF(NREM.GT.0) GOTO 280
68499  
68500 C...Compensate for missing momentum in global scheme (3 options).
68501   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
68502         DO 340 J=1,3
68503           PSI(J)=0D0
68504           DO 330 I=NSAV+NJET+1,N
68505             PSI(J)=PSI(J)+P(I,J)
68506   330     CONTINUE
68507   340   CONTINUE
68508         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
68509         PWS=0D0
68510         DO 350 I=NSAV+NJET+1,N
68511           IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
68512           IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
68513      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
68514           IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
68515   350   CONTINUE
68516         DO 370 I=NSAV+NJET+1,N
68517           IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
68518           IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
68519      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
68520           IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
68521           DO 360 J=1,3
68522             P(I,J)=P(I,J)-PSI(J)*PW/PWS
68523   360     CONTINUE
68524           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
68525   370   CONTINUE
68526  
68527 C...Compensate for missing momentum withing each jet separately.
68528       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
68529         DO 390 I=N+1,N+NJET
68530           K(I,1)=0
68531           DO 380 J=1,5
68532             P(I,J)=0D0
68533   380     CONTINUE
68534   390   CONTINUE
68535         DO 410 I=NSAV+NJET+1,N
68536           IR1=K(I,3)
68537           IR2=N+IR1-NSAV
68538           K(IR2,1)=K(IR2,1)+1
68539           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
68540      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
68541           DO 400 J=1,3
68542             P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
68543   400     CONTINUE
68544           P(IR2,4)=P(IR2,4)+P(I,4)
68545           P(IR2,5)=P(IR2,5)+PLS
68546   410   CONTINUE
68547         PSS=0D0
68548         DO 420 I=N+1,N+NJET
68549           IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
68550   420   CONTINUE
68551         DO 440 I=NSAV+NJET+1,N
68552           IR1=K(I,3)
68553           IR2=N+IR1-NSAV
68554           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
68555      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
68556           DO 430 J=1,3
68557             P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
68558      &      PLS*P(IR1,J)
68559   430     CONTINUE
68560           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
68561   440   CONTINUE
68562       ENDIF
68563  
68564 C...Scale momenta for energy conservation.
68565       IF(MOD(MSTJ(3),5).NE.0) THEN
68566         PMS=0D0
68567         PES=0D0
68568         PQS=0D0
68569         DO 450 I=NSAV+NJET+1,N
68570           PMS=PMS+P(I,5)
68571           PES=PES+P(I,4)
68572           PQS=PQS+P(I,5)**2/P(I,4)
68573   450   CONTINUE
68574         IF(PMS.GE.PECM) GOTO 150
68575         NECO=0
68576   460   NECO=NECO+1
68577         PFAC=(PECM-PQS)/(PES-PQS)
68578         PES=0D0
68579         PQS=0D0
68580         DO 480 I=NSAV+NJET+1,N
68581           DO 470 J=1,3
68582             P(I,J)=PFAC*P(I,J)
68583   470     CONTINUE
68584           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
68585           PES=PES+P(I,4)
68586           PQS=PQS+P(I,5)**2/P(I,4)
68587   480   CONTINUE
68588         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
68589       ENDIF
68590  
68591 C...Origin of produced particles and parton daughter pointers.
68592   490 DO 500 I=NSAV+NJET+1,N
68593         IF(MSTU(16).NE.2) K(I,3)=NSAV+1
68594         IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
68595   500 CONTINUE
68596       DO 510 I=NSAV+1,NSAV+NJET
68597         I1=K(I,3)
68598         K(I1,1)=K(I1,1)+10
68599         IF(MSTU(16).NE.2) THEN
68600           K(I1,4)=NSAV+1
68601           K(I1,5)=NSAV+1
68602         ELSE
68603           K(I1,4)=K(I1,4)-NJET+1
68604           K(I1,5)=K(I1,5)-NJET+1
68605           IF(K(I1,5).LT.K(I1,4)) THEN
68606             K(I1,4)=0
68607             K(I1,5)=0
68608           ENDIF
68609         ENDIF
68610   510 CONTINUE
68611  
68612 C...Document independent fragmentation system. Remove copy of jets.
68613       NSAV=NSAV+1
68614       K(NSAV,1)=11
68615       K(NSAV,2)=93
68616       K(NSAV,3)=IP
68617       K(NSAV,4)=NSAV+1
68618       K(NSAV,5)=N-NJET+1
68619       DO 520 J=1,4
68620         P(NSAV,J)=DPS(J)
68621         V(NSAV,J)=V(IP,J)
68622   520 CONTINUE
68623       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
68624       V(NSAV,5)=0D0
68625       DO 540 I=NSAV+NJET,N
68626         DO 530 J=1,5
68627           K(I-NJET+1,J)=K(I,J)
68628           P(I-NJET+1,J)=P(I,J)
68629           V(I-NJET+1,J)=V(I,J)
68630   530   CONTINUE
68631   540 CONTINUE
68632       N=N-NJET+1
68633       DO 550 IZ=MSTU90+1,MSTU(90)
68634         MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
68635   550 CONTINUE
68636  
68637 C...Boost back particle system. Set production vertices.
68638       IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
68639      &DPS(2)/DPS(4),DPS(3)/DPS(4))
68640       DO 570 I=NSAV+1,N
68641         DO 560 J=1,4
68642           V(I,J)=V(IP,J)
68643   560   CONTINUE
68644   570 CONTINUE
68645  
68646       RETURN
68647       END
68648  
68649 C*********************************************************************
68650  
68651 C...PYDECY
68652 C...Handles the decay of unstable particles.
68653  
68654       SUBROUTINE PYDECY(IP)
68655  
68656 C...Double precision and integer declarations.
68657       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68658       IMPLICIT INTEGER(I-N)
68659       INTEGER PYK,PYCHGE,PYCOMP
68660 C...Commonblocks.
68661       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68662       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68663       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68664       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
68665       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
68666 C...Local arrays.
68667       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
68668      &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
68669       CHARACTER CIDC*4
68670       DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
68671  
68672 C...Functions: momentum in two-particle decays and four-product.
68673       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
68674       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)
68675  
68676 C...Initial values.
68677       NTRY=0
68678       NSAV=N
68679       KFA=IABS(K(IP,2))
68680       KFS=ISIGN(1,K(IP,2))
68681       KC=PYCOMP(KFA)
68682       MSTJ(92)=0
68683  
68684 C...Choose lifetime and determine decay vertex.
68685       IF(K(IP,1).EQ.5) THEN
68686         V(IP,5)=0D0
68687       ELSEIF(K(IP,1).NE.4) THEN
68688         V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
68689       ENDIF
68690       DO 100 J=1,4
68691         VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
68692   100 CONTINUE
68693  
68694 C...Determine whether decay allowed or not.
68695       MOUT=0
68696       IF(MSTJ(22).EQ.2) THEN
68697         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
68698       ELSEIF(MSTJ(22).EQ.3) THEN
68699         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
68700       ELSEIF(MSTJ(22).EQ.4) THEN
68701         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
68702         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
68703       ENDIF
68704       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
68705         K(IP,1)=4
68706         RETURN
68707       ENDIF
68708  
68709 C...Interface to external tau decay library (for tau polarization).
68710       IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
68711  
68712 C...Starting values for pointers and momenta.
68713         ITAU=IP
68714         DO 110 J=1,4
68715           PTAU(J)=P(ITAU,J)
68716           PCMTAU(J)=P(ITAU,J)
68717   110   CONTINUE
68718  
68719 C...Iterate to find position and code of mother of tau.
68720         IMTAU=ITAU
68721   120   IMTAU=K(IMTAU,3)
68722  
68723         IF(IMTAU.EQ.0) THEN
68724 C...If no known origin then impossible to do anything further.
68725           KFORIG=0
68726           IORIG=0
68727  
68728         ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
68729 C...If tau -> tau + gamma then add gamma energy and loop.
68730           IF(K(K(IMTAU,4),2).EQ.22) THEN
68731             DO 130 J=1,4
68732               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
68733   130       CONTINUE
68734           ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
68735             DO 140 J=1,4
68736               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
68737   140       CONTINUE
68738           ENDIF
68739           GOTO 120
68740  
68741         ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
68742 C...If coming from weak decay of hadron then W is not stored in record,
68743 C...but can be reconstructed by adding neutrino momentum.
68744           KFORIG=-ISIGN(24,K(ITAU,2))
68745           IORIG=0
68746           DO 160 II=K(IMTAU,4),K(IMTAU,5)
68747             IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
68748               DO 150 J=1,4
68749                 PCMTAU(J)=PCMTAU(J)+P(II,J)
68750   150         CONTINUE
68751             ENDIF
68752   160     CONTINUE
68753  
68754         ELSE
68755 C...If coming from resonance decay then find latest copy of this
68756 C...resonance (may not completely agree).
68757           KFORIG=K(IMTAU,2)
68758           IORIG=IMTAU
68759           DO 170 II=IMTAU+1,IP-1
68760             IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
68761      &      ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
68762   170     CONTINUE
68763           DO 180 J=1,4
68764             PCMTAU(J)=P(IORIG,J)
68765   180     CONTINUE
68766         ENDIF
68767  
68768 C...Boost tau to rest frame of production process (where known)
68769 C...and rotate it to sit along +z axis.
68770         DO 190 J=1,3
68771           DBETAU(J)=PCMTAU(J)/PCMTAU(4)
68772   190   CONTINUE
68773         IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
68774      &  -DBETAU(2),-DBETAU(3))
68775         PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
68776         CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
68777         THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
68778         CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
68779  
68780 C...Call tau decay routine (if meaningful) and fill extra info.
68781         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68782           CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
68783           DO 200 II=NSAV+1,NSAV+NDECAY
68784             K(II,1)=1
68785             K(II,3)=IP
68786             K(II,4)=0
68787             K(II,5)=0
68788   200     CONTINUE
68789           N=NSAV+NDECAY
68790         ENDIF
68791  
68792 C...Boost back decay tau and decay products.
68793         DO 210 J=1,4
68794           P(ITAU,J)=PTAU(J)
68795   210   CONTINUE
68796         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68797           CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
68798           IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
68799      &    DBETAU(2),DBETAU(3))
68800  
68801 C...Skip past ordinary tau decay treatment.
68802           MMAT=0
68803           MBST=0
68804           ND=0
68805           GOTO 630
68806         ENDIF
68807       ENDIF
68808  
68809 C...B-Bbar mixing: flip sign of meson appropriately.
68810       MMIX=0
68811       IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
68812         XBBMIX=PARJ(76)
68813         IF(KFA.EQ.531) XBBMIX=PARJ(77)
68814         IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
68815         IF(MMIX.EQ.1) KFS=-KFS
68816       ENDIF
68817  
68818 C...Check existence of decay channels. Particle/antiparticle rules.
68819       KCA=KC
68820       IF(MDCY(KC,2).GT.0) THEN
68821         MDMDCY=MDME(MDCY(KC,2),2)
68822         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
68823       ENDIF
68824       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
68825         CALL PYERRM(9,'(PYDECY:) no decay channel defined')
68826         RETURN
68827       ENDIF
68828       IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
68829       IF(KCHG(KC,3).EQ.0) THEN
68830         KFSP=1
68831         KFSN=0
68832         IF(PYR(0).GT.0.5D0) KFS=-KFS
68833       ELSEIF(KFS.GT.0) THEN
68834         KFSP=1
68835         KFSN=0
68836       ELSE
68837         KFSP=0
68838         KFSN=1
68839       ENDIF
68840  
68841 C...Sum branching ratios of allowed decay channels.
68842   220 NOPE=0
68843       BRSU=0D0
68844       DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
68845         IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68846      &  KFSN*MDME(IDL,1).NE.3) GOTO 230
68847         IF(MDME(IDL,2).GT.100) GOTO 230
68848         NOPE=NOPE+1
68849         BRSU=BRSU+BRAT(IDL)
68850   230 CONTINUE
68851       IF(NOPE.EQ.0) THEN
68852         CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
68853         RETURN
68854       ENDIF
68855  
68856 C...Select decay channel among allowed ones.
68857   240 RBR=BRSU*PYR(0)
68858       IDL=MDCY(KCA,2)-1
68859   250 IDL=IDL+1
68860       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68861      &KFSN*MDME(IDL,1).NE.3) THEN
68862         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68863       ELSEIF(MDME(IDL,2).GT.100) THEN
68864         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68865       ELSE
68866         IDC=IDL
68867         RBR=RBR-BRAT(IDL)
68868         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
68869       ENDIF
68870  
68871 C...Start readout of decay channel: matrix element, reset counters.
68872       MMAT=MDME(IDC,2)
68873   260 NTRY=NTRY+1
68874       IF(MOD(NTRY,200).EQ.0) THEN
68875         WRITE(CIDC,'(I4)') IDC
68876 C...Do not print warning for some well-known special cases.
68877         IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
68878      &  CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
68879      &  CIDC)
68880         GOTO 240
68881       ENDIF
68882       IF(NTRY.GT.1000) THEN
68883         CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68884         IF(MSTU(21).GE.1) RETURN
68885       ENDIF
68886       I=N
68887       NP=0
68888       NQ=0
68889       MBST=0
68890       IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
68891       DO 270 J=1,4
68892         PV(1,J)=0D0
68893         IF(MBST.EQ.0) PV(1,J)=P(IP,J)
68894   270 CONTINUE
68895       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
68896       PV(1,5)=P(IP,5)
68897       PS=0D0
68898       PSQ=0D0
68899       MREM=0
68900       MHADDY=0
68901       IF(KFA.GT.80) MHADDY=1
68902 C.. Random flavour and popcorn system memory.
68903       IRNDMO=0
68904       JTMO=0
68905       MSTU(121)=0
68906       MSTU(125)=10
68907  
68908 C...Read out decay products. Convert to standard flavour code.
68909       JTMAX=5
68910       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
68911       DO 280 JT=1,JTMAX
68912         IF(JT.LE.5) KP=KFDP(IDC,JT)
68913         IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
68914         IF(KP.EQ.0) GOTO 280
68915         KPA=IABS(KP)
68916         KCP=PYCOMP(KPA)
68917         IF(KPA.GT.80) MHADDY=1
68918         IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
68919           KFP=KP
68920         ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
68921           KFP=KFS*KP
68922         ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
68923           KFP=-KFS*MOD(KFA/10,10)
68924         ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
68925           KFP=KFS*(100*MOD(KFA/10,100)+3)
68926         ELSEIF(KPA.EQ.81) THEN
68927           KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
68928         ELSEIF(KP.EQ.82) THEN
68929           CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
68930           IF(KFP.EQ.0) GOTO 260
68931           KFP=-KFP
68932           IRNDMO=1
68933           MSTJ(93)=1
68934           IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
68935         ELSEIF(KP.EQ.-82) THEN
68936           KFP=MSTU(124)
68937         ENDIF
68938         IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
68939  
68940 C...Add decay product to event record or to quark flavour list.
68941         KFPA=IABS(KFP)
68942         KQP=KCHG(KCP,2)
68943         IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
68944           NQ=NQ+1
68945           KFLO(NQ)=KFP
68946 C...set rndmflav popcorn system pointer
68947           IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
68948           MSTJ(93)=2
68949           PSQ=PSQ+PYMASS(KFLO(NQ))
68950         ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
68951      &    MOD(NQ,2).EQ.1) THEN
68952           NQ=NQ-1
68953           PS=PS-P(I,5)
68954           K(I,1)=1
68955           KFI=K(I,2)
68956           CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
68957           IF(K(I,2).EQ.0) GOTO 260
68958           MSTJ(93)=1
68959           P(I,5)=PYMASS(K(I,2))
68960           PS=PS+P(I,5)
68961         ELSE
68962           I=I+1
68963           NP=NP+1
68964           IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
68965           IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
68966           K(I,1)=1+MOD(NQ,2)
68967           IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
68968           IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
68969           K(I,2)=KFP
68970           K(I,3)=IP
68971           K(I,4)=0
68972           K(I,5)=0
68973           P(I,5)=PYMASS(KFP)
68974           PS=PS+P(I,5)
68975         ENDIF
68976   280 CONTINUE
68977  
68978 C...Check masses for resonance decays.
68979       IF(MHADDY.EQ.0) THEN
68980         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
68981       ENDIF
68982  
68983 C...Choose decay multiplicity in phase space model.
68984   290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
68985         PSP=PS
68986         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
68987         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
68988   300   NTRY=NTRY+1
68989 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
68990         IF(IRNDMO.EQ.0) THEN
68991            MSTU(121)=0
68992            JTMO=0
68993         ELSEIF(IRNDMO.EQ.1) THEN
68994            IRNDMO=2
68995         ELSE
68996            GOTO 260
68997         ENDIF
68998         IF(NTRY.GT.1000) THEN
68999           CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
69000           IF(MSTU(21).GE.1) RETURN
69001         ENDIF
69002         IF(MMAT.LE.20) THEN
69003           GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
69004      &    SIN(PARU(2)*PYR(0))
69005           ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
69006           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
69007           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
69008           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
69009           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
69010         ELSE
69011           ND=MMAT-20
69012         ENDIF
69013 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
69014         MSTU(125)=ND-NQ/2
69015         IF(MSTU(121).GT.MSTU(125)) GOTO 300
69016  
69017 C...Form hadrons from flavour content.
69018         DO 310 JT=1,NQ
69019           KFL1(JT)=KFLO(JT)
69020   310   CONTINUE
69021         IF(ND.EQ.NP+NQ/2) GOTO 330
69022         DO 320 I=N+NP+1,N+ND-NQ/2
69023 C.. Stick to started popcorn system, else pick side at random
69024           JT=JTMO
69025           IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
69026           CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
69027           IF(K(I,2).EQ.0) GOTO 300
69028           MSTU(125)=MSTU(125)-1
69029           JTMO=0
69030           IF(MSTU(121).GT.0) JTMO=JT
69031           KFL1(JT)=-KFL2
69032   320   CONTINUE
69033   330   JT=2
69034         JT2=3
69035         JT3=4
69036         IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
69037         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
69038      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
69039         IF(JT.EQ.3) JT2=2
69040         IF(JT.EQ.4) JT3=2
69041         CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
69042         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
69043         IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
69044         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
69045  
69046 C...Check that sum of decay product masses not too large.
69047         PS=PSP
69048         DO 340 I=N+NP+1,N+ND
69049           K(I,1)=1
69050           K(I,3)=IP
69051           K(I,4)=0
69052           K(I,5)=0
69053           P(I,5)=PYMASS(K(I,2))
69054           PS=PS+P(I,5)
69055   340   CONTINUE
69056         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
69057  
69058 C...Rescale energy to subtract off spectator quark mass.
69059       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
69060      &  .AND.NP.GE.3) THEN
69061         PS=PS-P(N+NP,5)
69062         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
69063         DO 350 J=1,5
69064           P(N+NP,J)=PQT*PV(1,J)
69065           PV(1,J)=(1D0-PQT)*PV(1,J)
69066   350   CONTINUE
69067         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
69068         ND=NP-1
69069         MREM=1
69070  
69071 C...Fully specified final state: check mass broadening effects.
69072       ELSE
69073         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
69074         ND=NP
69075       ENDIF
69076  
69077 C...Determine position of grandmother, number of sisters.
69078       NM=0
69079       KFAS=0
69080       MSGN=0
69081       IF(MMAT.EQ.3) THEN
69082         IM=K(IP,3)
69083         IF(IM.LT.0.OR.IM.GE.IP) IM=0
69084         IF(IM.NE.0) KFAM=IABS(K(IM,2))
69085         IF(IM.NE.0) THEN
69086           DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
69087             IF(K(IL,3).EQ.IM) NM=NM+1
69088             IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
69089   360     CONTINUE
69090           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
69091      &    MOD(KFAM/1000,10).NE.0) NM=0
69092           IF(NM.EQ.2) THEN
69093             KFAS=IABS(K(ISIS,2))
69094             IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
69095      &      MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
69096           ENDIF
69097         ENDIF
69098       ENDIF
69099  
69100 C...Kinematics of one-particle decays.
69101       IF(ND.EQ.1) THEN
69102         DO 370 J=1,4
69103           P(N+1,J)=P(IP,J)
69104   370   CONTINUE
69105         GOTO 630
69106       ENDIF
69107  
69108 C...Calculate maximum weight ND-particle decay.
69109       PV(ND,5)=P(N+ND,5)
69110       IF(ND.GE.3) THEN
69111         WTMAX=1D0/WTCOR(ND-2)
69112         PMAX=PV(1,5)-PS+P(N+ND,5)
69113         PMIN=0D0
69114         DO 380 IL=ND-1,1,-1
69115           PMAX=PMAX+P(N+IL,5)
69116           PMIN=PMIN+P(N+IL+1,5)
69117           WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
69118   380   CONTINUE
69119       ENDIF
69120  
69121 C...Find virtual gamma mass in Dalitz decay.
69122   390 IF(ND.EQ.2) THEN
69123       ELSEIF(MMAT.EQ.2) THEN
69124         PMES=4D0*PMAS(11,1)**2
69125         PMRHO2=PMAS(131,1)**2
69126         PGRHO2=PMAS(131,2)**2
69127   400   PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
69128         WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
69129      &  (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
69130      &  ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
69131         IF(WT.LT.PYR(0)) GOTO 400
69132         PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
69133  
69134 C...M-generator gives weight. If rejected, try again.
69135       ELSE
69136   410   RORD(1)=1D0
69137         DO 440 IL1=2,ND-1
69138           RSAV=PYR(0)
69139           DO 420 IL2=IL1-1,1,-1
69140             IF(RSAV.LE.RORD(IL2)) GOTO 430
69141             RORD(IL2+1)=RORD(IL2)
69142   420     CONTINUE
69143   430     RORD(IL2+1)=RSAV
69144   440   CONTINUE
69145         RORD(ND)=0D0
69146         WT=1D0
69147         DO 450 IL=ND-1,1,-1
69148           PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
69149      &    (PV(1,5)-PS)
69150           WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
69151   450   CONTINUE
69152         IF(WT.LT.PYR(0)*WTMAX) GOTO 410
69153       ENDIF
69154  
69155 C...Perform two-particle decays in respective CM frame.
69156   460 DO 480 IL=1,ND-1
69157         PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
69158         UE(3)=2D0*PYR(0)-1D0
69159         PHI=PARU(2)*PYR(0)
69160         UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
69161         UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
69162         DO 470 J=1,3
69163           P(N+IL,J)=PA*UE(J)
69164           PV(IL+1,J)=-PA*UE(J)
69165   470   CONTINUE
69166         P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
69167         PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
69168   480 CONTINUE
69169  
69170 C...Lorentz transform decay products to lab frame.
69171       DO 490 J=1,4
69172         P(N+ND,J)=PV(ND,J)
69173   490 CONTINUE
69174       DO 530 IL=ND-1,1,-1
69175         DO 500 J=1,3
69176           BE(J)=PV(IL,J)/PV(IL,4)
69177   500   CONTINUE
69178         GA=PV(IL,4)/PV(IL,5)
69179         DO 520 I=N+IL,N+ND
69180           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
69181           DO 510 J=1,3
69182             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
69183   510     CONTINUE
69184           P(I,4)=GA*(P(I,4)+BEP)
69185   520   CONTINUE
69186   530 CONTINUE
69187  
69188 C...Check that no infinite loop in matrix element weight.
69189       NTRY=NTRY+1
69190       IF(NTRY.GT.800) GOTO 560
69191  
69192 C...Matrix elements for omega and phi decays.
69193       IF(MMAT.EQ.1) THEN
69194         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
69195      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
69196      &  +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
69197         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
69198  
69199 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
69200       ELSEIF(MMAT.EQ.2) THEN
69201         FOUR12=FOUR(N+1,N+2)
69202         FOUR13=FOUR(N+1,N+3)
69203         WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
69204      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
69205         IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
69206  
69207 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
69208 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
69209 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
69210       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
69211         FOUR10=FOUR(IP,IM)
69212         FOUR12=FOUR(IP,N+1)
69213         FOUR02=FOUR(IM,N+1)
69214         PMS1=P(IP,5)**2
69215         PMS0=P(IM,5)**2
69216         PMS2=P(N+1,5)**2
69217         IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
69218         IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
69219      &  PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
69220         HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
69221         HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
69222         IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
69223  
69224 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
69225       ELSEIF(MMAT.EQ.4) THEN
69226         HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
69227         HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
69228         HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
69229         WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
69230      &  ((1D0-HX3)/(HX1*HX2))**2
69231         IF(WT.LT.2D0*PYR(0)) GOTO 390
69232         IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
69233      &  GOTO 390
69234  
69235 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
69236       ELSEIF(MMAT.EQ.41) THEN
69237         IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
69238         IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
69239         HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
69240         IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
69241  
69242 C...Matrix elements for weak decays (only semileptonic for c and b)
69243       ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
69244      &  .AND.ND.EQ.3) THEN
69245         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
69246         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
69247         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
69248       ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
69249         DO 550 J=1,4
69250           P(N+NP+1,J)=0D0
69251           DO 540 IS=N+3,N+NP
69252             P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
69253   540     CONTINUE
69254   550   CONTINUE
69255         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
69256         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
69257         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
69258       ENDIF
69259  
69260 C...Scale back energy and reattach spectator.
69261   560 IF(MREM.EQ.1) THEN
69262         DO 570 J=1,5
69263           PV(1,J)=PV(1,J)/(1D0-PQT)
69264   570   CONTINUE
69265         ND=ND+1
69266         MREM=0
69267       ENDIF
69268  
69269 C...Low invariant mass for system with spectator quark gives particle,
69270 C...not two jets. Readjust momenta accordingly.
69271       IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
69272         MSTJ(93)=1
69273         PM2=PYMASS(K(N+2,2))
69274         MSTJ(93)=1
69275         PM3=PYMASS(K(N+3,2))
69276         IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
69277      &  (PARJ(32)+PM2+PM3)**2) GOTO 630
69278         K(N+2,1)=1
69279         KFTEMP=K(N+2,2)
69280         CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
69281         IF(K(N+2,2).EQ.0) GOTO 260
69282         P(N+2,5)=PYMASS(K(N+2,2))
69283         PS=P(N+1,5)+P(N+2,5)
69284         PV(2,5)=P(N+2,5)
69285         MMAT=0
69286         ND=2
69287         GOTO 460
69288       ELSEIF(MMAT.EQ.44) THEN
69289         MSTJ(93)=1
69290         PM3=PYMASS(K(N+3,2))
69291         MSTJ(93)=1
69292         PM4=PYMASS(K(N+4,2))
69293         IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
69294      &  (PARJ(32)+PM3+PM4)**2) GOTO 600
69295         K(N+3,1)=1
69296         KFTEMP=K(N+3,2)
69297         CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
69298         IF(K(N+3,2).EQ.0) GOTO 260
69299         P(N+3,5)=PYMASS(K(N+3,2))
69300         DO 580 J=1,3
69301           P(N+3,J)=P(N+3,J)+P(N+4,J)
69302   580   CONTINUE
69303         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)
69304         HA=P(N+1,4)**2-P(N+2,4)**2
69305         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
69306         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
69307      &  (P(N+1,3)-P(N+2,3))**2
69308         HD=(PV(1,4)-P(N+3,4))**2
69309         HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
69310         HF=HD*HC-HB**2
69311         HG=HD*HC-HA*HB
69312         HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
69313         DO 590 J=1,3
69314           PCOR=HH*(P(N+1,J)-P(N+2,J))
69315           P(N+1,J)=P(N+1,J)+PCOR
69316           P(N+2,J)=P(N+2,J)-PCOR
69317   590   CONTINUE
69318         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)
69319         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)
69320         ND=ND-1
69321       ENDIF
69322  
69323 C...Check invariant mass of W jets. May give one particle or start over.
69324   600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
69325      &.AND.IABS(K(N+1,2)).LT.10) THEN
69326         PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
69327         MSTJ(93)=1
69328         PM1=PYMASS(K(N+1,2))
69329         MSTJ(93)=1
69330         PM2=PYMASS(K(N+2,2))
69331         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
69332         KFLDUM=INT(1.5D0+PYR(0))
69333         CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
69334         CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
69335         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
69336         PSM=PYMASS(KF1)+PYMASS(KF2)
69337         IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
69338         IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
69339         IF(MMAT.EQ.48) GOTO 390
69340         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
69341         K(N+1,1)=1
69342         KFTEMP=K(N+1,2)
69343         CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
69344         IF(K(N+1,2).EQ.0) GOTO 260
69345         P(N+1,5)=PYMASS(K(N+1,2))
69346         K(N+2,2)=K(N+3,2)
69347         P(N+2,5)=P(N+3,5)
69348         PS=P(N+1,5)+P(N+2,5)
69349         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
69350         PV(2,5)=P(N+3,5)
69351         MMAT=0
69352         ND=2
69353         GOTO 460
69354       ENDIF
69355  
69356 C...Phase space decay of partons from W decay.
69357   610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
69358         KFLO(1)=K(N+1,2)
69359         KFLO(2)=K(N+2,2)
69360         K(N+1,1)=K(N+3,1)
69361         K(N+1,2)=K(N+3,2)
69362         DO 620 J=1,5
69363           PV(1,J)=P(N+1,J)+P(N+2,J)
69364           P(N+1,J)=P(N+3,J)
69365   620   CONTINUE
69366         PV(1,5)=PMR
69367         N=N+1
69368         NP=0
69369         NQ=2
69370         PS=0D0
69371         MSTJ(93)=2
69372         PSQ=PYMASS(KFLO(1))
69373         MSTJ(93)=2
69374         PSQ=PSQ+PYMASS(KFLO(2))
69375         MMAT=11
69376         GOTO 290
69377       ENDIF
69378  
69379 C...Boost back for rapidly moving particle.
69380   630 N=N+ND
69381       IF(MBST.EQ.1) THEN
69382         DO 640 J=1,3
69383           BE(J)=P(IP,J)/P(IP,4)
69384   640   CONTINUE
69385         GA=P(IP,4)/P(IP,5)
69386         DO 660 I=NSAV+1,N
69387           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
69388           DO 650 J=1,3
69389             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
69390   650     CONTINUE
69391           P(I,4)=GA*(P(I,4)+BEP)
69392   660   CONTINUE
69393       ENDIF
69394  
69395 C...Fill in position of decay vertex.
69396       DO 680 I=NSAV+1,N
69397         DO 670 J=1,4
69398           V(I,J)=VDCY(J)
69399   670   CONTINUE
69400         V(I,5)=0D0
69401   680 CONTINUE
69402  
69403 C...Set up for parton shower evolution from jets.
69404       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
69405         K(NSAV+1,1)=3
69406         K(NSAV+2,1)=3
69407         K(NSAV+3,1)=3
69408         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
69409         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
69410         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
69411         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
69412         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
69413         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
69414         MSTJ(92)=-(NSAV+1)
69415       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
69416         K(NSAV+2,1)=3
69417         K(NSAV+3,1)=3
69418         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
69419         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
69420         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
69421         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
69422         MSTJ(92)=NSAV+2
69423       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
69424      &  IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
69425         K(NSAV+1,1)=3
69426         K(NSAV+2,1)=3
69427         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
69428         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
69429         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
69430         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
69431         MSTJ(92)=NSAV+1
69432       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
69433      &  IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
69434         MSTJ(92)=NSAV+1
69435       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
69436      &  THEN
69437         K(NSAV+1,1)=3
69438         K(NSAV+2,1)=3
69439         K(NSAV+3,1)=3
69440         KCP=PYCOMP(K(NSAV+1,2))
69441         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
69442         JCON=4
69443         IF(KQP.LT.0) JCON=5
69444         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
69445         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
69446         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
69447         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
69448         MSTJ(92)=NSAV+1
69449       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
69450         K(NSAV+1,1)=3
69451         K(NSAV+3,1)=3
69452         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
69453         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
69454         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
69455         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
69456         MSTJ(92)=NSAV+1
69457       ENDIF
69458  
69459 C...Mark decayed particle; special option for B-Bbar mixing.
69460       IF(K(IP,1).EQ.5) K(IP,1)=15
69461       IF(K(IP,1).LE.10) K(IP,1)=11
69462       IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
69463       K(IP,4)=NSAV+1
69464       K(IP,5)=N
69465  
69466       RETURN
69467       END
69468  
69469  
69470 C*********************************************************************
69471  
69472 C...PYDCYK
69473 C...Handles flavour production in the decay of unstable particles
69474 C...and small string clusters.
69475  
69476       SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
69477  
69478 C...Double precision and integer declarations.
69479       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69480       IMPLICIT INTEGER(I-N)
69481       INTEGER PYK,PYCHGE,PYCOMP
69482 C...Commonblocks.
69483       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69484       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69485       SAVE /PYDAT1/,/PYDAT2/
69486  
69487  
69488 C.. Call PYKFDI directly if no popcorn option is on
69489       IF(MSTJ(12).LT.2) THEN
69490          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
69491          MSTU(124)=KFL3
69492          RETURN
69493       ENDIF
69494  
69495       KFL3=0
69496       KF=0
69497       IF(KFL1.EQ.0) RETURN
69498       KF1A=IABS(KFL1)
69499       KF2A=IABS(KFL2)
69500  
69501       NSTO=130
69502       NMAX=MIN(MSTU(125),10)
69503  
69504 C.. Identify rank 0 cluster qq
69505       IRANK=1
69506       IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
69507  
69508       IF(KF2A.GT.0)THEN
69509 C.. Join jets: Fails if store not empty
69510          IF(MSTU(121).GT.0) THEN
69511             MSTU(121)=0
69512             RETURN
69513          ENDIF
69514          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
69515       ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
69516 C.. Pick popcorn meson from store, return same qq, decrease store
69517          KF=MSTU(NSTO+MSTU(121))
69518          KFL3=-KFL1
69519          MSTU(121)=MSTU(121)-1
69520       ELSE
69521 C.. Generate new flavour. Then done if no diquark is generated
69522   100    CALL PYKFDI(KFL1,0,KFL3,KF)
69523          IF(MSTU(121).EQ.-1) GOTO 100
69524          MSTU(124)=KFL3
69525          IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
69526  
69527 C.. Simple case if no dynamical popcorn suppressions are considered
69528          IF(MSTJ(12).LT.4) THEN
69529             IF(MSTU(121).EQ.0) RETURN
69530             NMES=1
69531             KFPREV=-KFL3
69532             CALL PYKFDI(KFPREV,0,KFL3,KFM)
69533 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
69534             IF(IABS(KFL3).LE.10)THEN
69535                KFL3=-KFPREV
69536                RETURN
69537             ENDIF
69538             GOTO 120
69539          ENDIF
69540  
69541 C test output qq against fake Gamma, then return if no popcorn.
69542          GB=2D0
69543          IF(IRANK.NE.0)THEN
69544             CALL PYZDIS(1,2103,5D0,Z)
69545             GB=5D0*(1D0-Z)/Z
69546             IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
69547                MSTU(121)=0
69548                GOTO 100
69549             ENDIF
69550          ENDIF
69551          IF(MSTU(121).EQ.0) RETURN
69552  
69553 C..Set store size memory. Pick fake dynamical variables of qq.
69554          NMES=MSTU(121)
69555          CALL PYPTDI(1,PX3,PY3)
69556          X=1D0
69557          POPM=0D0
69558          G=GB
69559          POPG=GB
69560  
69561 C.. Pick next popcorn meson, test with fake dynamical variables
69562   110    KFPREV=-KFL3
69563          PX1=-PX3
69564          PY1=-PY3
69565          CALL PYKFDI(KFPREV,0,KFL3,KFM)
69566          IF(MSTU(121).EQ.-1) GOTO 100
69567          CALL PYPTDI(KFL3,PX3,PY3)
69568          PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
69569          CALL PYZDIS(KFPREV,KFL3,PM,Z)
69570          G=(1D0-Z)*(G+PM/Z)
69571          X=(1D0-Z)*X
69572  
69573          PTST=1D0
69574          GTST=1D0
69575          RTST=PYR(0)
69576          IF(MSTJ(12).GT.4)THEN
69577             POPMN=SQRT((1D0-X)*(G/X-GB))
69578             POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69579             PTST=EXP((POPM-POPMN)*PARF(193))
69580             POPM=POPMN
69581          ENDIF
69582          IF(IRANK.NE.0)THEN
69583             POPGN=X*GB
69584             GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
69585             POPG=POPGN
69586          ENDIF
69587          IF(RTST.GT.PTST*GTST)THEN
69588             MSTU(121)=0
69589             IF(RTST.GT.PTST) MSTU(121)=-1
69590             GOTO 100
69591          ENDIF
69592  
69593 C.. Store meson
69594   120    IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
69595          IF(MSTU(121).GT.0) GOTO 110
69596  
69597 C.. Test accepted system size. If OK set global popcorn size variable.
69598          IF(NMES.GT.NMAX)THEN
69599             KF=0
69600             KFL3=0
69601             RETURN
69602          ENDIF
69603          MSTU(121)=NMES
69604       ENDIF
69605  
69606       RETURN
69607       END
69608  
69609 C********************************************************************
69610  
69611 C...PYKFDI
69612 C...Generates a new flavour pair and combines off a hadron
69613  
69614       SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
69615  
69616 C...Double precision and integer declarations.
69617       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69618       IMPLICIT INTEGER(I-N)
69619       INTEGER PYK,PYCHGE,PYCOMP
69620 C...Commonblocks.
69621       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69622       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69623       SAVE /PYDAT1/,/PYDAT2/
69624 C...Local arrays.
69625       DIMENSION PD(7)
69626  
69627       IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0)  CALL PYKFIN
69628  
69629 C...Default flavour values. Input consistency checks.
69630       KF1A=IABS(KFL1)
69631       KF2A=IABS(KFL2)
69632       KFL3=0
69633       KF=0
69634       IF(KF1A.EQ.0) RETURN
69635       IF(KF2A.NE.0)THEN
69636         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
69637         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
69638         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
69639       ENDIF
69640  
69641 C...Check if tabulated flavour probabilities are to be used.
69642       IF(MSTJ(15).EQ.1) THEN
69643         IF(MSTJ(12).GE.5)  CALL PYERRM(29,
69644      &        '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
69645      &        ' together with MSTJ(12)>=5 modification')
69646         KTAB1=-1
69647         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
69648         KFL1A=MOD(KF1A/1000,10)
69649         KFL1B=MOD(KF1A/100,10)
69650         KFL1S=MOD(KF1A,10)
69651         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
69652      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
69653         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
69654         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
69655         KTAB2=0
69656         IF(KF2A.NE.0) THEN
69657           KTAB2=-1
69658           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
69659           KFL2A=MOD(KF2A/1000,10)
69660           KFL2B=MOD(KF2A/100,10)
69661           KFL2S=MOD(KF2A,10)
69662           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
69663      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
69664           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
69665         ENDIF
69666         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
69667       ENDIF
69668  
69669 C.. Recognize rank 0 diquark case
69670   100 IRANK=1
69671       KFDIQ=MAX(KF1A,KF2A)
69672       IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
69673  
69674 C.. Join two flavours to meson or baryon. Test for popcorn.
69675       IF(KF2A.GT.0)THEN
69676         MBARY=0
69677         IF(KFDIQ.GT.10) THEN
69678           IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
69679      &         CALL PYNMES(KFDIQ)
69680           IF(MSTU(121).NE.0) THEN
69681              MSTU(121)=0
69682              RETURN
69683           ENDIF
69684           MBARY=2
69685         ENDIF
69686         KFQOLD=KF1A
69687         KFQVER=KF2A
69688         GOTO 130
69689       ENDIF
69690  
69691 C.. Separate incoming flavours, curtain flavour consistency check
69692       KFIN=KFL1
69693       KFQOLD=KF1A
69694       KFQPOP=KF1A/10000
69695       IF(KF1A.GT.10)THEN
69696          KFIN=-KFL1
69697          KFL1A=MOD(KF1A/1000,10)
69698          KFL1B=MOD(KF1A/100,10)
69699          IF(IRANK.EQ.0)THEN
69700             QAWT=1D0
69701             IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
69702             IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
69703             KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
69704          ENDIF
69705          IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
69706              MSTU(121)=0
69707              RETURN
69708           ENDIF
69709          KFQOLD=KFL1A+KFL1B-KFQPOP
69710       ENDIF
69711  
69712 C...Meson/baryon choice. Set number of mesons if starting a popcorn
69713 C...system.
69714   110 MBARY=0
69715       IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
69716          IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
69717             MBARY=1
69718             CALL PYNMES(0)
69719          ENDIF
69720       ELSEIF(KF1A.GT.10)THEN
69721          MBARY=2
69722          IF(IRANK.EQ.0) CALL PYNMES(KF1A)
69723          IF(MSTU(121).GT.0) MBARY=-1
69724       ENDIF
69725  
69726 C..x->H+q: Choose single vertex quark. Jump to form hadron.
69727       IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
69728          KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
69729          KFL3=ISIGN(KFQVER,-KFIN)
69730          GOTO 130
69731       ENDIF
69732  
69733 C..x->H+qq: (IDW=proper PARF position for diquark weights)
69734       IDW=160
69735       IF(MBARY.EQ.1)THEN
69736          IF(MSTU(121).EQ.0) IDW=150
69737          SQWT=PARF(IDW+1)
69738          IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
69739          KFQPOP=1+INT((2D0+SQWT)*PYR(0))
69740 C..   Shift to s-curtain parameters if needed
69741          IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
69742             PARF(194)=PARF(138)*PARF(139)
69743             PARF(193)=PARJ(8)+PARJ(9)
69744          ENDIF
69745       ENDIF
69746  
69747 C.. x->H+qq: Get vertex quark
69748       IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69749          IDW=MSTU(122)
69750          MSTU(121)=MSTU(121)-1
69751          IF(IDW.EQ.170) THEN
69752             IF(MSTU(121).EQ.0)THEN
69753                IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
69754             ELSE
69755                IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
69756             ENDIF
69757          ELSE
69758             IF(MSTU(121).EQ.0)THEN
69759                IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
69760             ELSE
69761                IPOS=3*5+5*4+MIN(KFQOLD-1,4)
69762             ENDIF
69763          ENDIF
69764          IPOS=200+30*IPOS+1
69765  
69766          IMES=-1
69767          RMES=PYR(0)*PARF(194)
69768   120    IMES=IMES+1
69769          RMES=RMES-PARF(IPOS+IMES)
69770          IF(IMES.EQ.30) THEN
69771             MSTU(121)=-1
69772             KF=-111
69773             RETURN
69774          ENDIF
69775          IF(RMES.GT.0D0) GOTO 120
69776          KMUL=IMES/5
69777          KFJ=2*KMUL+1
69778          IF(KMUL.EQ.2) KFJ=10003
69779          IF(KMUL.EQ.3) KFJ=10001
69780          IF(KMUL.EQ.4) KFJ=20003
69781          IF(KMUL.EQ.5) KFJ=5
69782          IDIAG=0
69783          KFQVER=MOD(IMES,5)+1
69784          IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
69785          IF(KFQVER.GT.3)THEN
69786             IDIAG=KFQVER-3
69787             KFQVER=KFQOLD
69788          ENDIF
69789       ELSE
69790          IF(MBARY.EQ.-1) IDW=170
69791          SQWT=PARF(IDW+2)
69792          IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
69793          IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
69794          KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
69795          IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
69796             KFQVER=KFQPOP
69797             IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
69798          ENDIF
69799       ENDIF
69800  
69801 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
69802       KFLDS=3
69803       IF(KFQPOP.NE.KFQVER)THEN
69804          SWT=PARF(IDW+7)
69805          IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
69806          IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
69807          IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
69808       ENDIF
69809       KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
69810      &      +10000*KFQPOP
69811       KFL3=ISIGN(KFDIQ,KFIN)
69812  
69813 C..x->M+y: flavour for meson.
69814   130 IF(MBARY.LE.0)THEN
69815         KFLA=MAX(KFQOLD,KFQVER)
69816         KFLB=MIN(KFQOLD,KFQVER)
69817         KFS=ISIGN(1,KFL1)
69818         IF(KFLA.NE.KFQOLD) KFS=-KFS
69819 C... Form meson, with spin and flavour mixing for diagonal states.
69820         IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69821            IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
69822            IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
69823            RETURN
69824         ENDIF
69825         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
69826         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
69827         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
69828         IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
69829           IF(PYR(0).LT.PARJ(14)) KMUL=2
69830         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
69831           RMUL=PYR(0)
69832           IF(RMUL.LT.PARJ(15)) KMUL=3
69833           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
69834           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
69835         ENDIF
69836         KFLS=3
69837         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69838         IF(KMUL.EQ.5) KFLS=5
69839         IF(KFLA.NE.KFLB)THEN
69840           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
69841         ELSE
69842           RMIX=PYR(0)
69843           IMIX=2*KFLA+10*KMUL
69844           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
69845      &    INT(RMIX+PARF(IMIX)))+KFLS
69846           IF(KFLA.GE.4) KF=110*KFLA+KFLS
69847         ENDIF
69848         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
69849         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
69850  
69851 C..Optional extra suppression of eta and eta'.
69852 C..Allow shift to qq->B+q in old version (set IRANK to 0)
69853         IF(KF.EQ.221.OR.KF.EQ.331)THEN
69854            IF(PYR(0).GT.PARJ(25+KF/300))THEN
69855               IF(KF2A.GT.0) GOTO 130
69856               IF(MSTJ(12).LT.4) IRANK=0
69857               GOTO 110
69858            ENDIF
69859         ENDIF
69860         MSTU(121)=0
69861  
69862 C.. x->B+y: Flavour for baryon
69863       ELSE
69864         KFLA=KFQVER
69865         IF(KF1A.LE.10) KFLA=KFQOLD
69866         KFLB=MOD(KFDIQ/1000,10)
69867         KFLC=MOD(KFDIQ/100,10)
69868         KFLDS=MOD(KFDIQ,10)
69869         KFLD=MAX(KFLA,KFLB,KFLC)
69870         KFLF=MIN(KFLA,KFLB,KFLC)
69871         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69872  
69873 C...  SU(6) factors for formation of baryon.
69874         KBARY=3
69875         KDMAX=5
69876         KFLG=KFLB
69877         IF(KFLB.NE.KFLC)THEN
69878            KBARY=2*KFLDS-1
69879            KDMAX=1+KFLDS/2
69880            IF(KFLB.GT.2) KDMAX=KDMAX+2
69881         ENDIF
69882         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
69883            KBARY=KBARY+1
69884            KFLG=KFLA
69885         ENDIF
69886  
69887         SU6MAX=PARF(140+KDMAX)
69888         SU6DEC=PARJ(18)
69889         SU6S  =PARF(146)
69890         IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
69891            SU6MAX=1D0
69892            SU6DEC=1D0
69893            SU6S  =1D0
69894         ENDIF
69895         SU6OCT=PARF(60+KBARY)
69896         IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
69897            SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
69898            IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
69899         ELSE
69900            IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
69901         ENDIF
69902         SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
69903  
69904 C..   SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
69905         IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
69906            MSTU(121)=0
69907            IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
69908            GOTO 110
69909         ENDIF
69910  
69911 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
69912         KSIG=1
69913         KFLS=2
69914         IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
69915         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
69916           KSIG=KFLDS/3
69917           IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
69918         ENDIF
69919         KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
69920         IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
69921       ENDIF
69922       RETURN
69923  
69924 C...Use tabulated probabilities to select new flavour and hadron.
69925   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
69926         KT3L=1
69927         KT3U=6
69928       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
69929         KT3L=1
69930         KT3U=6
69931       ELSEIF(KTAB2.EQ.0) THEN
69932         KT3L=1
69933         KT3U=22
69934       ELSE
69935         KT3L=KTAB2
69936         KT3U=KTAB2
69937       ENDIF
69938       RFL=0D0
69939       DO 160 KTS=0,2
69940         DO 150 KT3=KT3L,KT3U
69941           RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
69942   150   CONTINUE
69943   160 CONTINUE
69944       RFL=PYR(0)*RFL
69945       DO 180 KTS=0,2
69946         KTABS=KTS
69947         DO 170 KT3=KT3L,KT3U
69948           KTAB3=KT3
69949           RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
69950           IF(RFL.LE.0D0) GOTO 190
69951   170   CONTINUE
69952   180 CONTINUE
69953   190 CONTINUE
69954  
69955 C...Reconstruct flavour of produced quark/diquark.
69956       IF(KTAB3.LE.6) THEN
69957         KFL3A=KTAB3
69958         KFL3B=0
69959         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
69960       ELSE
69961         KFL3A=1
69962         IF(KTAB3.GE.8) KFL3A=2
69963         IF(KTAB3.GE.11) KFL3A=3
69964         IF(KTAB3.GE.16) KFL3A=4
69965         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
69966         KFL3=1000*KFL3A+100*KFL3B+1
69967         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
69968      &  KFL3+2
69969         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
69970       ENDIF
69971  
69972 C...Reconstruct meson code.
69973       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
69974      &KFL3B.NE.0)) THEN
69975         RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69976      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
69977         KF=110+2*KTABS+1
69978         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
69979         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69980      &  25*KTABS)) KF=330+2*KTABS+1
69981       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
69982         KFLA=MAX(KTAB1,KTAB3)
69983         KFLB=MIN(KTAB1,KTAB3)
69984         KFS=ISIGN(1,KFL1)
69985         IF(KFLA.NE.KF1A) KFS=-KFS
69986         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69987       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
69988         KFS=ISIGN(1,KFL1)
69989         IF(KFL1A.EQ.KFL3A) THEN
69990           KFLA=MAX(KFL1B,KFL3B)
69991           KFLB=MIN(KFL1B,KFL3B)
69992           IF(KFLA.NE.KFL1B) KFS=-KFS
69993         ELSEIF(KFL1A.EQ.KFL3B) THEN
69994           KFLA=KFL3A
69995           KFLB=KFL1B
69996           KFS=-KFS
69997         ELSEIF(KFL1B.EQ.KFL3A) THEN
69998           KFLA=KFL1A
69999           KFLB=KFL3B
70000         ELSEIF(KFL1B.EQ.KFL3B) THEN
70001           KFLA=MAX(KFL1A,KFL3A)
70002           KFLB=MIN(KFL1A,KFL3A)
70003           IF(KFLA.NE.KFL1A) KFS=-KFS
70004         ELSE
70005           CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
70006           GOTO 100
70007         ENDIF
70008         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
70009  
70010 C...Reconstruct baryon code.
70011       ELSE
70012         IF(KTAB1.GE.7) THEN
70013           KFLA=KFL3A
70014           KFLB=KFL1A
70015           KFLC=KFL1B
70016         ELSE
70017           KFLA=KFL1A
70018           KFLB=KFL3A
70019           KFLC=KFL3B
70020         ENDIF
70021         KFLD=MAX(KFLA,KFLB,KFLC)
70022         KFLF=MIN(KFLA,KFLB,KFLC)
70023         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
70024         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
70025         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
70026       ENDIF
70027  
70028 C...Check that constructed flavour code is an allowed one.
70029       IF(KFL2.NE.0) KFL3=0
70030       KC=PYCOMP(KF)
70031       IF(KC.EQ.0) THEN
70032         CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
70033      &  'failed')
70034         GOTO 100
70035       ENDIF
70036  
70037       RETURN
70038       END
70039  
70040 C*********************************************************************
70041  
70042 C...PYNMES
70043 C...Generates number of popcorn mesons and stores some relevant
70044 C...parameters.
70045  
70046       SUBROUTINE PYNMES(KFDIQ)
70047  
70048 C...Double precision and integer declarations.
70049       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70050       IMPLICIT INTEGER(I-N)
70051       INTEGER PYK,PYCHGE,PYCOMP
70052 C...Commonblocks.
70053       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70054       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70055       SAVE /PYDAT1/,/PYDAT2/
70056  
70057       MSTU(121)=0
70058       IF(MSTJ(12).LT.2) RETURN
70059  
70060 C..Old version: Get 1 or 0 popcorn mesons
70061       IF(MSTJ(12).LT.5)THEN
70062          POPWT=PARF(131)
70063          IF(KFDIQ.NE.0) THEN
70064             KFDIQA=IABS(KFDIQ)
70065             KFA=MOD(KFDIQA/1000,10)
70066             KFB=MOD(KFDIQA/100,10)
70067             KFS=MOD(KFDIQA,10)
70068             POPWT=PARF(132)
70069             IF(KFA.EQ.3) POPWT=PARF(133)
70070             IF(KFB.EQ.3) POPWT=PARF(134)
70071             IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
70072          ENDIF
70073          MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
70074          RETURN
70075       ENDIF
70076  
70077 C..New version: Store popcorn- or rank 0 diquark parameters
70078       MSTU(122)=170
70079       PARF(193)=PARJ(8)
70080       PARF(194)=PARF(139)
70081       IF(KFDIQ.NE.0) THEN
70082          MSTU(122)=180
70083          PARF(193)=PARJ(10)
70084          PARF(194)=PARF(140)
70085       ENDIF
70086       IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
70087          IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
70088      &        '(PYNMES:) Neglecting too large popcorn possibility')
70089          RETURN
70090       ENDIF
70091  
70092 C..New version: Get number of popcorn mesons
70093   100 RTST=PYR(0)
70094       MSTU(121)=-1
70095   110 MSTU(121)=MSTU(121)+1
70096       RTST=RTST/PARF(194)
70097       IF(RTST.LT.1D0) GOTO 110
70098       IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
70099      &     (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
70100       RETURN
70101       END
70102  
70103 C***************************************************************
70104  
70105 C...PYKFIN
70106 C...Precalculates a set of diquark and popcorn weights.
70107  
70108       SUBROUTINE PYKFIN
70109  
70110 C...Double precision and integer declarations.
70111       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70112       IMPLICIT INTEGER(I-N)
70113       INTEGER PYK,PYCHGE,PYCOMP
70114 C...Commonblocks.
70115       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70116       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70117       SAVE /PYDAT1/,/PYDAT2/
70118  
70119       DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
70120  
70121  
70122       MSTU(123)=1
70123 C..Diquark indices for dimensional variables
70124       IUD1=1
70125       IUU1=2
70126       IUS0=3
70127       ISU0=4
70128       IUS1=5
70129       ISU1=6
70130       ISS1=7
70131  
70132 C.. *** SU(6) factors **
70133 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
70134       PARF(146)=1D0
70135       IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
70136       IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
70137      &     '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
70138       DO 100 I=1,6
70139          SU6(I)=PARF(60+I)
70140          SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
70141   100 CONTINUE
70142       SU6(8)=SU6(2)*4/(3*PARF(146)+1)
70143       SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
70144       DO 110 I=1,6
70145          SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
70146          SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
70147   110 CONTINUE
70148  
70149 C..SU(6)max            q       q'     s,c,b
70150       SU6MUD    =MAX(SU6(1) ,       SU6(8) )
70151       SU6M(IUD1)=MAX(SU6(5) ,       SU6(12))
70152       SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
70153       SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
70154       SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
70155       SU6M(IUS0)=SU6M(ISU0)
70156       SU6M(ISS1)=SU6M(IUU1)
70157       SU6M(IUS1)=SU6M(ISU1)
70158  
70159 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
70160       PARF(141)=SU6MUD
70161       PARF(142)=SU6M(IUD1)
70162       PARF(143)=SU6M(ISU0)
70163       PARF(144)=SU6M(ISU1)
70164       PARF(145)=SU6M(ISS1)
70165  
70166 C..diquark SU(6) survival =
70167 C..sum over quark (quark tunnel weight)*(SU(6)).
70168       PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
70169       DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
70170       DMB(IUS0)=DMB(ISU0)
70171       DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
70172       DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
70173       DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
70174       DMB(IUS1)=DMB(ISU1)
70175       DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
70176  
70177 C.. *** Tunneling factors for Diquark production***
70178 C.. T: half a curtain pair = sqrt(curtain pair factor)
70179       IF(MSTJ(12).GE.5) THEN
70180          PMUD0=PYMASS(2101)
70181          PMUD1=PYMASS(2103)-PMUD0
70182          PMUS0=PYMASS(3201)-PMUD0
70183          PMUS1=PYMASS(3203)-PMUS0-PMUD0
70184          PMSS1=PYMASS(3303)-PMUS0-PMUD0
70185          QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
70186          QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
70187          QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
70188          QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
70189          QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
70190          QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
70191          QBB(IUD1)=QBB(IUU1)
70192       ELSE
70193          PAR2M=SQRT(PARJ(2))
70194          PAR3M=SQRT(PARJ(3))
70195          PAR4M=SQRT(PARJ(4))
70196          QBB(ISU0)=PAR2M*PAR3M
70197          QBB(IUS0)=PAR3M
70198          QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
70199          QBB(IUU1)=PAR4M
70200          QBB(ISU1)=PAR4M*QBB(ISU0)
70201          QBB(IUS1)=PAR4M*QBB(IUS0)
70202          QBB(IUD1)=PAR4M
70203       ENDIF
70204  
70205 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
70206       QBM(ISU0)=QBB(ISU0)
70207       QBM(IUS0)=PARJ(2)*QBB(IUS0)
70208       QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
70209       QBM(IUU1)=6D0*QBB(IUU1)
70210       QBM(ISU1)=3D0*QBB(ISU1)
70211       QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
70212       QBM(IUD1)=3D0*QBB(IUD1)
70213  
70214 C.. Combine T and tau to diquark weight for q-> B+B+..
70215       DO 120 I=1,7
70216          QBB(I)=QBB(I)*QBM(I)
70217   120 CONTINUE
70218  
70219       IF(MSTJ(12).GE.5)THEN
70220 C..New version: tau  for rank 0 diquark.
70221          DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
70222          DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
70223          DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
70224          DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
70225          DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
70226          DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
70227          DMB(7+IUD1)=DMB(7+IUU1)/2D0
70228  
70229 C..New version: curtain flavour ratios.
70230 C.. s/u for q->B+M+...
70231 C.. s/u for rank 0 diquark: su -> ...M+B+...
70232 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
70233          WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
70234          PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
70235          WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
70236          PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
70237          PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
70238      &        (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
70239       ELSE
70240 C..Old version: reset unused rank 0 diquark weights and
70241 C..             unused diquark SU(6) survival weights
70242          DO 130 I=1,7
70243             IF(MSTJ(12).LT.3) DMB(I)=1D0
70244             DMB(7+I)=1D0
70245   130    CONTINUE
70246  
70247 C..Old version: Shuffle PARJ(7) into tau
70248          QBM(IUS0)=QBM(IUS0)*PARJ(7)
70249          QBM(ISS1)=QBM(ISS1)*PARJ(7)
70250          QBM(IUS1)=QBM(IUS1)*PARJ(7)
70251  
70252 C..Old version: curtain flavour ratios.
70253 C.. s/u for q->B+M+...
70254 C.. s/u for rank 0 diquark: su -> ...M+B+...
70255 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
70256          WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
70257          PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
70258          PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
70259          PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
70260       ENDIF
70261  
70262 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
70263 C..  rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
70264       DO 140 I=1,7
70265          DMB(7+I)=DMB(7+I)*DMB(I)
70266          DMB(I)=DMB(I)*QBM(I)
70267          QBM(I)=QBM(I)*SU6M(I)/SU6MUD
70268          QBB(I)=QBB(I)*SU6M(I)/SU6MUD
70269   140 CONTINUE
70270  
70271 C.. *** Popcorn factors ***
70272  
70273       IF(MSTJ(12).LT.5)THEN
70274 C.. Old version: Resulting popcorn weights.
70275          PARF(138)=PARJ(6)
70276          WS=PARF(135)*PARF(138)
70277          WQ=WU*PARJ(5)/3D0
70278          PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
70279          PARF(133)=WQ*
70280      &        (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
70281          PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
70282          PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
70283      &                 WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
70284      &        (1D0+QBB(IUD1)+QBB(IUU1)+
70285      &        2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
70286       ELSE
70287 C..New version: Store weights for popcorn mesons,
70288 C..get prel. popcorn weights.
70289          DO 150 IPOS=201,1400
70290             PARF(IPOS)=0D0
70291   150    CONTINUE
70292          DO 160 I=138,140
70293             PARF(I)=0D0
70294   160    CONTINUE
70295          IPOS=200
70296          PARF(193)=PARJ(8)
70297          DO 240 MR=0,7,7
70298            IF(MR.EQ.7) PARF(193)=PARJ(10)
70299            SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
70300      &          (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
70301            QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
70302            DO 230 NMES=0,1
70303              IF(NMES.EQ.1) SQWT=PARJ(2)
70304              DO 220 KFQPOP=1,4
70305                IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
70306                IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
70307                   SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
70308                   QQWT=0.5D0
70309                   IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
70310                   IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
70311                ENDIF
70312                DO 210 KFQOLD =1,5
70313                   IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
70314                   IF(NMES.EQ.1) THEN
70315                      IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
70316                      IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
70317                   ENDIF
70318                   WTTOT=0D0
70319                   WTFAIL=0D0
70320       DO 190 KMUL=0,5
70321          PJWT=PARJ(12+KMUL)
70322          IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
70323          IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
70324          IF(PJWT.LE.0D0) GOTO 190
70325          IF(PJWT.GT.1D0) PJWT=1D0
70326          IMES=5*KMUL
70327          IMIX=2*KFQOLD+10*KMUL
70328          KFJ=2*KMUL+1
70329          IF(KMUL.EQ.2) KFJ=10003
70330          IF(KMUL.EQ.3) KFJ=10001
70331          IF(KMUL.EQ.4) KFJ=20003
70332          IF(KMUL.EQ.5) KFJ=5
70333          DO 180 KFQVER =1,3
70334             KFLA=MAX(KFQOLD,KFQVER)
70335             KFLB=MIN(KFQOLD,KFQVER)
70336             SWT=PARJ(11+KFLA/3+KFLA/4)
70337             IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
70338             SWT=SWT*PJWT
70339             QWT=SQWT/(2D0+SQWT)
70340             IF(KFQVER.LT.3)THEN
70341                IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
70342                IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
70343             ENDIF
70344             IF(KFQVER.NE.KFQOLD)THEN
70345                IMES=IMES+1
70346                KFM=100*KFLA+10*KFLB+KFJ
70347                PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
70348                PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
70349                WTTOT=WTTOT+PARF(IPOS+IMES)
70350             ELSE
70351                DO 170 ID=3,5
70352                   IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
70353                   IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
70354                   IF(ID.EQ.5) DWT=PARF(IMIX)
70355                   KFM=110*(ID-2)+KFJ
70356                   PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
70357                   PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
70358                   IF(KMUL.EQ.0.AND.ID.GT.3) THEN
70359                      WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
70360                      PARF(IPOS+5*KMUL+ID)=
70361      &                    PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
70362                   ENDIF
70363                   WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
70364   170          CONTINUE
70365             ENDIF
70366   180    CONTINUE
70367   190 CONTINUE
70368                   DO 200 IMES=1,30
70369                      PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
70370   200             CONTINUE
70371                   IF(MR.EQ.7) PARF(140)=
70372      &                 MAX(PARF(140),WTTOT/(1D0-WTFAIL))
70373                   IF(MR.EQ.0) PARF(139-KFQPOP/3)=
70374      &                 MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
70375                   IPOS=IPOS+30
70376   210           CONTINUE
70377   220         CONTINUE
70378   230       CONTINUE
70379   240    CONTINUE
70380          IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
70381          MSTU(121)=0
70382  
70383       ENDIF
70384  
70385 C..Recombine diquark weights to flavour and spin ratios
70386       PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
70387      &        (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
70388       PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
70389       PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
70390       PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
70391       PARF(155)=QBB(ISU1)/QBB(ISU0)
70392       PARF(156)=QBB(IUS1)/QBB(IUS0)
70393       PARF(157)=QBB(IUD1)
70394  
70395       PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
70396      &        (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
70397       PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
70398       PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
70399       PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
70400       PARF(165)=QBM(ISU1)/QBM(ISU0)
70401       PARF(166)=QBM(IUS1)/QBM(IUS0)
70402       PARF(167)=QBM(IUD1)
70403  
70404       PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
70405      &        (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
70406       PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
70407       PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
70408       PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
70409       PARF(175)=DMB(ISU1)/DMB(ISU0)
70410       PARF(176)=DMB(IUS1)/DMB(IUS0)
70411       PARF(177)=DMB(IUD1)
70412  
70413       PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
70414       PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
70415       PARF(187)=DMB(7+IUD1)
70416  
70417       RETURN
70418       END
70419  
70420  
70421 C*********************************************************************
70422  
70423 C...PYPTDI
70424 C...Generates transverse momentum according to a Gaussian.
70425  
70426       SUBROUTINE PYPTDI(KFL,PX,PY)
70427  
70428 C...Double precision and integer declarations.
70429       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70430       IMPLICIT INTEGER(I-N)
70431       INTEGER PYK,PYCHGE,PYCOMP
70432 C...Commonblocks.
70433       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70434       SAVE /PYDAT1/
70435  
70436 C...Generate p_T and azimuthal angle, gives p_x and p_y.
70437       KFLA=IABS(KFL)
70438       PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
70439       IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
70440       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
70441       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
70442       PHI=PARU(2)*PYR(0)
70443       PX=PT*COS(PHI)
70444       PY=PT*SIN(PHI)
70445  
70446       RETURN
70447       END
70448  
70449 C*********************************************************************
70450  
70451 C...PYZDIS
70452 C...Generates the longitudinal splitting variable z.
70453  
70454       SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
70455  
70456 C...Double precision and integer declarations.
70457       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70458       IMPLICIT INTEGER(I-N)
70459       INTEGER PYK,PYCHGE,PYCOMP
70460 C...Commonblocks.
70461       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70462       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70463       SAVE /PYDAT1/,/PYDAT2/
70464  
70465 C...Check if heavy flavour fragmentation.
70466       KFLA=IABS(KFL1)
70467       KFLB=IABS(KFL2)
70468       KFLH=KFLA
70469       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
70470  
70471 C...Lund symmetric scaling function: determine parameters of shape.
70472       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
70473      &MSTJ(11).GE.4) THEN
70474         FA=PARJ(41)
70475         IF(MSTJ(91).EQ.1) FA=PARJ(43)
70476         IF(KFLB.GE.10) FA=FA+PARJ(45)
70477         FBB=PARJ(42)
70478         IF(MSTJ(91).EQ.1) FBB=PARJ(44)
70479         FB=FBB*PR
70480         FC=1D0
70481         IF(KFLA.GE.10) FC=FC-PARJ(45)
70482         IF(KFLB.GE.10) FC=FC+PARJ(45)
70483         IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
70484           FRED=PARJ(46)
70485           IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
70486           FC=FC+FRED*FBB*PARF(100+KFLH)**2
70487         ENDIF
70488         MC=1
70489         IF(ABS(FC-1D0).GT.0.01D0) MC=2
70490  
70491 C...Determine position of maximum. Special cases for a = 0 or a = c.
70492         IF(FA.LT.0.02D0) THEN
70493           MA=1
70494           ZMAX=1D0
70495           IF(FC.GT.FB) ZMAX=FB/FC
70496         ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
70497           MA=2
70498           ZMAX=FB/(FB+FC)
70499         ELSE
70500           MA=3
70501           ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
70502           IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
70503         ENDIF
70504  
70505 C...Subdivide z range if distribution very peaked near endpoint.
70506         MMAX=2
70507         IF(ZMAX.LT.0.1D0) THEN
70508           MMAX=1
70509           ZDIV=2.75D0*ZMAX
70510           IF(MC.EQ.1) THEN
70511             FINT=1D0-LOG(ZDIV)
70512           ELSE
70513             ZDIVC=ZDIV**(1D0-FC)
70514             FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
70515           ENDIF
70516         ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
70517           MMAX=3
70518           FSCB=SQRT(4D0+(FC/FB)**2)
70519           ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
70520           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
70521           ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
70522           FINT=1D0+FB*(1D0-ZDIV)
70523         ENDIF
70524  
70525 C...Choice of z, preweighted for peaks at low or high z.
70526   100   Z=PYR(0)
70527         FPRE=1D0
70528         IF(MMAX.EQ.1) THEN
70529           IF(FINT*PYR(0).LE.1D0) THEN
70530             Z=ZDIV*Z
70531           ELSEIF(MC.EQ.1) THEN
70532             Z=ZDIV**Z
70533             FPRE=ZDIV/Z
70534           ELSE
70535             Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
70536             FPRE=(ZDIV/Z)**FC
70537           ENDIF
70538         ELSEIF(MMAX.EQ.3) THEN
70539           IF(FINT*PYR(0).LE.1D0) THEN
70540             Z=ZDIV+LOG(Z)/FB
70541             FPRE=EXP(FB*(Z-ZDIV))
70542           ELSE
70543             Z=ZDIV+Z*(1D0-ZDIV)
70544           ENDIF
70545         ENDIF
70546  
70547 C...Weighting according to correct formula.
70548         IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
70549         FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
70550         IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
70551         FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
70552         IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
70553  
70554 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
70555       ELSE
70556         FC=PARJ(50+MAX(1,KFLH))
70557         IF(MSTJ(91).EQ.1) FC=PARJ(59)
70558   110   Z=PYR(0)
70559         IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
70560           IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
70561         ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
70562           IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
70563      &    GOTO 110
70564         ELSE
70565           IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
70566           IF(FC.LT.0D0) Z=Z**(-1D0/FC)
70567         ENDIF
70568       ENDIF
70569  
70570       RETURN
70571       END
70572  
70573 C*********************************************************************
70574  
70575 C...PYSHOW
70576 C...Generates timelike parton showers from given partons.
70577  
70578       SUBROUTINE PYSHOW(IP1,IP2,QMAX)
70579  
70580 C...Double precision and integer declarations.
70581       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70582       IMPLICIT INTEGER(I-N)
70583       INTEGER PYK,PYCHGE,PYCOMP
70584 C...Parameter statement to help give large particle numbers.
70585       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70586      &KEXCIT=4000000,KDIMEN=5000000)
70587       PARAMETER (MAXNUR=1000)
70588 C...Commonblocks.
70589       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
70590       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70591       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70592       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70593       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70594       COMMON/PYINT1/MINT(400),VINT(400)
70595       SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
70596 C...Local arrays.
70597       DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
70598      &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
70599      &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
70600      &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
70601      &IREF(1000)
70602  
70603 C...Check that QMAX not too low.
70604       IF(MSTJ(41).LE.0) THEN
70605         RETURN
70606       ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
70607         IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
70608       ELSE
70609         IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
70610      &  RETURN
70611       ENDIF
70612  
70613 C...Store positions of shower initiating partons.
70614       MPSPD=0
70615       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
70616         NPA=1
70617         IPA(1)=IP1
70618       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
70619      &  MSTU(32))) THEN
70620         NPA=2
70621         IPA(1)=IP1
70622         IPA(2)=IP2
70623       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
70624      &  .AND.IP2.GE.-80) THEN
70625         NPA=IABS(IP2)
70626         DO 100 I=1,NPA
70627           IPA(I)=IP1+I-1
70628   100   CONTINUE
70629       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
70630      &IP2.EQ.-100) THEN
70631         MPSPD=1
70632         NPA=2
70633         IPA(1)=IP1+6
70634         IPA(2)=IP1+7
70635       ELSE
70636         CALL PYERRM(12,
70637      &  '(PYSHOW:) failed to reconstruct showering system')
70638         IF(MSTU(21).GE.1) RETURN
70639       ENDIF
70640  
70641 C...Send off to PYPTFS for pT-ordered evolution if requested,
70642 C...if at least 2 partons, and without predefined shower branchings.
70643       IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
70644      &MPSPD.EQ.0) THEN
70645         NPART=NPA
70646         DO 110 II=1,NPART
70647           IPART(II)=IPA(II)
70648           PTPART(II)=0.5D0*QMAX
70649   110   CONTINUE
70650         CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
70651         RETURN
70652       ENDIF
70653  
70654 C...Initialization of cutoff masses etc.
70655       DO 120 IFL=0,40
70656         ISCOL(IFL)=0
70657         ISCHG(IFL)=0
70658         KSH(IFL)=0
70659   120 CONTINUE
70660       ISCOL(21)=1
70661       KSH(21)=1
70662       PMTH(1,21)=PYMASS(21)
70663       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
70664       PMTH(3,21)=2D0*PMTH(2,21)
70665       PMTH(4,21)=PMTH(3,21)
70666       PMTH(5,21)=PMTH(3,21)
70667       PMTH(1,22)=PYMASS(22)
70668       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
70669       PMTH(3,22)=2D0*PMTH(2,22)
70670       PMTH(4,22)=PMTH(3,22)
70671       PMTH(5,22)=PMTH(3,22)
70672       PMQTH1=PARJ(82)
70673       IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
70674       PMQT1E=MIN(PMQTH1,PARJ(90))
70675       PMQTH2=PMTH(2,21)
70676       IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
70677       PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
70678       DO 130 IFL=1,5
70679         ISCOL(IFL)=1
70680         IF(MSTJ(41).GE.2) ISCHG(IFL)=1
70681         KSH(IFL)=1
70682         PMTH(1,IFL)=PYMASS(IFL)
70683         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
70684         PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
70685         PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70686         PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70687   130 CONTINUE
70688       DO 140 IFL=11,15,2
70689         IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
70690         IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
70691         PMTH(1,IFL)=PYMASS(IFL)
70692         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
70693         PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
70694         PMTH(4,IFL)=PMTH(3,IFL)
70695         PMTH(5,IFL)=PMTH(3,IFL)
70696   140 CONTINUE
70697       PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
70698       ALAMS=PARJ(81)**2
70699       ALFM=LOG(PT2MIN/ALAMS)
70700  
70701 C...Check on phase space available for emission.
70702       IREJ=0
70703       DO 150 J=1,5
70704         PS(J)=0D0
70705   150 CONTINUE
70706       PM=0D0
70707       KFLA(2)=0
70708       DO 170 I=1,NPA
70709         KFLA(I)=IABS(K(IPA(I),2))
70710         PMA(I)=P(IPA(I),5)
70711 C...Special cutoff masses for initial partons (may be a heavy quark,
70712 C...squark, ..., and need not be on the mass shell).
70713         IR=30+I
70714         IF(NPA.LE.1) IREF(I)=IR
70715         IF(NPA.GE.2) IREF(I+1)=IR
70716         ISCOL(IR)=0
70717         ISCHG(IR)=0
70718         KSH(IR)=0
70719         IF(KFLA(I).LE.8) THEN
70720           ISCOL(IR)=1
70721           IF(MSTJ(41).GE.2) ISCHG(IR)=1
70722         ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
70723      &  KFLA(I).EQ.17) THEN
70724           IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
70725         ELSEIF(KFLA(I).EQ.21) THEN
70726           ISCOL(IR)=1
70727         ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
70728      &  (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
70729           ISCOL(IR)=1
70730         ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
70731           ISCOL(IR)=1
70732 C...QUARKONIA+++
70733 C...same for QQ~[3S18]
70734         ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
70735      &  KFLA(I).EQ.9900553)) THEN
70736           ISCOL(IR)=1
70737 C...QUARKONIA---
70738         ENDIF
70739 
70740 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
70741 C...(only intended for studying the effects of switching such rad on/off)
70742         IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
70743           ISCOL(IR)=0
70744           ISCHG(IR)=0
70745         ENDIF
70746 
70747         IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
70748         PMTH(1,IR)=PMA(I)
70749         IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
70750           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
70751           PMTH(3,IR)=PMTH(2,IR)+PMQTH2
70752           PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70753           PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70754         ELSEIF(ISCOL(IR).EQ.1) THEN
70755           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
70756           PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
70757           PMTH(4,IR)=PMTH(3,IR)
70758           PMTH(5,IR)=PMTH(3,IR)
70759         ELSEIF(ISCHG(IR).EQ.1) THEN
70760           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
70761           PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
70762           PMTH(4,IR)=PMTH(3,IR)
70763           PMTH(5,IR)=PMTH(3,IR)
70764         ENDIF
70765         IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
70766         PM=PM+PMA(I)
70767         IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
70768         DO 160 J=1,4
70769           PS(J)=PS(J)+P(IPA(I),J)
70770   160   CONTINUE
70771   170 CONTINUE
70772       IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
70773       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70774       IF(NPA.EQ.1) PS(5)=PS(4)
70775       IF(PS(5).LE.PM+PMQT1E) RETURN
70776  
70777 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70778       KFSRCE=0
70779       IF(IP2.LE.0) THEN
70780       ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
70781         KFSRCE=IABS(K(K(IP1,3),2))
70782       ELSE
70783         IPAR1=MAX(1,K(IP1,3))
70784         IPAR2=MAX(1,K(IP2,3))
70785         IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
70786      &       KFSRCE=IABS(K(K(IPAR1,3),2))
70787       ENDIF
70788       ITYPES=0
70789       IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70790       IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70791       IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70792       IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70793       IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70794       IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70795       IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70796       IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70797  
70798 C...Identify two primary showerers.
70799       ITYPE1=0
70800       IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
70801       IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
70802       IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
70803       IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
70804       IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
70805       IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
70806       IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
70807       IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
70808       ITYPE2=0
70809       IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
70810       IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
70811       IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
70812       IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
70813       IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
70814       IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
70815       IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
70816       IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
70817  
70818 C...Order of showerers. Presence of gluino.
70819       ITYPMN=MIN(ITYPE1,ITYPE2)
70820       ITYPMX=MAX(ITYPE1,ITYPE2)
70821       IORD=1
70822       IF(ITYPE1.GT.ITYPE2) IORD=2
70823       IGLUI=0
70824       IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70825  
70826 C...Check if 3-jet matrix elements to be used.
70827       M3JC=0
70828       ALPHA=0.5D0
70829       IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
70830         IF(MSTJ(38).NE.0) THEN
70831           M3JC=MSTJ(38)
70832           ALPHA=PARJ(80)
70833           MSTJ(38)=0
70834         ELSEIF(MSTJ(47).GE.6) THEN
70835           M3JC=MSTJ(47)
70836         ELSE
70837           ICLASS=1
70838           ICOMBI=4
70839  
70840 C...Vector/axial vector -> q + qbar; q -> q + V.
70841           IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70842      &    ITYPES.EQ.3)) THEN
70843             ICLASS=2
70844             IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70845               ICOMBI=1
70846             ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70847      &      K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
70848 C...gamma*/Z0: assume e+e- initial state if unknown.
70849               EI=-1D0
70850               IF(KFSRCE.EQ.23) THEN
70851                 IANNFL=K(K(IP1,3),3)
70852                 IF(IANNFL.NE.0) THEN
70853                   KANNFL=IABS(K(IANNFL,2))
70854                   IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70855                 ENDIF
70856               ENDIF
70857               AI=SIGN(1D0,EI+0.1D0)
70858               VI=AI-4D0*EI*PARU(102)
70859               EF=KCHG(KFLA(1),1)/3D0
70860               AF=SIGN(1D0,EF+0.1D0)
70861               VF=AF-4D0*EF*PARU(102)
70862               XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70863               SH=PS(5)**2
70864               SQMZ=PMAS(23,1)**2
70865               SQWZ=PS(5)*PMAS(23,2)
70866               SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70867               VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70868      &        (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70869               AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70870               ICOMBI=3
70871               ALPHA=VECT/(VECT+AXIV)
70872             ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70873               ICOMBI=4
70874             ENDIF
70875 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70876           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70877             ICLASS=2
70878           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70879      &    ITYPES.EQ.1)) THEN
70880             ICLASS=3
70881  
70882 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70883           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70884             ICLASS=4
70885             IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70886               ICOMBI=1
70887             ELSEIF(KFSRCE.EQ.36) THEN
70888               ICOMBI=2
70889             ENDIF
70890           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70891      &    ITYPES.EQ.1)) THEN
70892             ICLASS=5
70893  
70894 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70895           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70896      &    ITYPES.EQ.3)) THEN
70897             ICLASS=6
70898           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70899      &    ITYPES.EQ.2)) THEN
70900             ICLASS=7
70901           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70902             ICLASS=8
70903           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70904      &    ITYPES.EQ.2)) THEN
70905             ICLASS=9
70906  
70907 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70908           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70909      &    ITYPES.EQ.5)) THEN
70910             ICLASS=10
70911           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70912      &    ITYPES.EQ.2)) THEN
70913             ICLASS=11
70914           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70915      &    ITYPES.EQ.1)) THEN
70916             ICLASS=12
70917  
70918 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70919           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70920             ICLASS=13
70921           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70922      &    ITYPES.EQ.2)) THEN
70923             ICLASS=14
70924           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70925      &    ITYPES.EQ.1)) THEN
70926             ICLASS=15
70927  
70928 C...g -> ~g + ~g (eikonal approximation).
70929           ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70930             ICLASS=16
70931           ENDIF
70932 
70933 C...Revert to eikonal approximation for gluon in final state.
70934           IF(KFLA1.EQ.21.OR.KFLA2.EQ.21) ICLASS=1 
70935 
70936           M3JC=5*ICLASS+ICOMBI
70937         ENDIF
70938       ENDIF
70939  
70940 C...Find if interference with initial state partons.
70941       MIIS=0
70942       IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
70943      &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
70944       IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
70945      &MIIS=MSTJ(50)-3
70946       IF(MIIS.NE.0) THEN
70947         DO 190 I=1,2
70948           KCII(I)=0
70949           KCA=PYCOMP(KFLA(I))
70950           IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
70951           NIIS(I)=0
70952           IF(KCII(I).NE.0) THEN
70953             DO 180 J=1,2
70954               ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
70955               IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
70956      &        (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
70957                 NIIS(I)=NIIS(I)+1
70958                 IIIS(I,NIIS(I))=ICSI
70959               ENDIF
70960   180       CONTINUE
70961           ENDIF
70962   190   CONTINUE
70963         IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
70964       ENDIF
70965  
70966 C...Boost interfering initial partons to rest frame
70967 C...and reconstruct their polar and azimuthal angles.
70968       IF(MIIS.NE.0) THEN
70969         DO 210 I=1,2
70970           DO 200 J=1,5
70971             K(N+I,J)=K(IPA(I),J)
70972             P(N+I,J)=P(IPA(I),J)
70973             V(N+I,J)=0D0
70974   200     CONTINUE
70975   210   CONTINUE
70976         DO 230 I=3,2+NIIS(1)
70977           DO 220 J=1,5
70978             K(N+I,J)=K(IIIS(1,I-2),J)
70979             P(N+I,J)=P(IIIS(1,I-2),J)
70980             V(N+I,J)=0D0
70981   220     CONTINUE
70982   230   CONTINUE
70983         DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70984           DO 240 J=1,5
70985             K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
70986             P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
70987             V(N+I,J)=0D0
70988   240     CONTINUE
70989   250   CONTINUE
70990         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
70991      &  -PS(2)/PS(4),-PS(3)/PS(4))
70992         PHI=PYANGL(P(N+1,1),P(N+1,2))
70993         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
70994         THE=PYANGL(P(N+1,3),P(N+1,1))
70995         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
70996         DO 260 I=3,2+NIIS(1)
70997           THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
70998           PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
70999   260   CONTINUE
71000         DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
71001           THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
71002      &    SQRT(P(N+I,1)**2+P(N+I,2)**2))
71003           PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
71004   270   CONTINUE
71005       ENDIF
71006  
71007 C...Boost 3 or more partons to their rest frame.
71008       IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
71009      &-PS(2)/PS(4),-PS(3)/PS(4))
71010  
71011 C...Define imagined single initiator of shower for parton system.
71012       NS=N
71013       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
71014         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
71015         IF(MSTU(21).GE.1) RETURN
71016       ENDIF
71017   280 N=NS
71018       IF(NPA.GE.2) THEN
71019         K(N+1,1)=11
71020         K(N+1,2)=21
71021         K(N+1,3)=0
71022         K(N+1,4)=0
71023         K(N+1,5)=0
71024         P(N+1,1)=0D0
71025         P(N+1,2)=0D0
71026         P(N+1,3)=0D0
71027         P(N+1,4)=PS(5)
71028         P(N+1,5)=PS(5)
71029         V(N+1,5)=PS(5)**2
71030         N=N+1
71031         IREF(1)=21
71032       ENDIF
71033  
71034 C...Loop over partons that may branch.
71035       NEP=NPA
71036       IM=NS
71037       IF(NPA.EQ.1) IM=NS-1
71038   290 IM=IM+1
71039       IF(N.GT.NS) THEN
71040         IF(IM.GT.N) GOTO 600
71041         KFLM=IABS(K(IM,2))
71042         IR=IREF(IM-NS)
71043         IF(KSH(IR).EQ.0) GOTO 290
71044         IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
71045         IGM=K(IM,3)
71046       ELSE
71047         IGM=-1
71048       ENDIF
71049       IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
71050         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
71051         IF(MSTU(21).GE.1) RETURN
71052       ENDIF
71053  
71054 C...Position of aunt (sister to branching parton).
71055 C...Origin and flavour of daughters.
71056       IAU=0
71057       IF(IGM.GT.0) THEN
71058         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
71059         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
71060       ENDIF
71061       IF(IGM.GE.0) THEN
71062         K(IM,4)=N+1
71063         DO 300 I=1,NEP
71064           K(N+I,3)=IM
71065   300   CONTINUE
71066       ELSE
71067         K(N+1,3)=IPA(1)
71068       ENDIF
71069       IF(IGM.LE.0) THEN
71070         DO 310 I=1,NEP
71071           K(N+I,2)=K(IPA(I),2)
71072   310   CONTINUE
71073       ELSEIF(KFLM.NE.21) THEN
71074         K(N+1,2)=K(IM,2)
71075         K(N+2,2)=K(IM,5)
71076         IREF(N+1-NS)=IREF(IM-NS)
71077         IREF(N+2-NS)=IABS(K(N+2,2))
71078       ELSEIF(K(IM,5).EQ.21) THEN
71079         K(N+1,2)=21
71080         K(N+2,2)=21
71081         IREF(N+1-NS)=21
71082         IREF(N+2-NS)=21
71083       ELSE
71084         K(N+1,2)=K(IM,5)
71085         K(N+2,2)=-K(IM,5)
71086         IREF(N+1-NS)=IABS(K(N+1,2))
71087         IREF(N+2-NS)=IABS(K(N+2,2))
71088       ENDIF
71089  
71090 C...Reset flags on daughters and tries made.
71091       DO 320 IP=1,NEP
71092         K(N+IP,1)=3
71093         K(N+IP,4)=0
71094         K(N+IP,5)=0
71095         KFLD(IP)=IABS(K(N+IP,2))
71096         IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
71097         ITRY(IP)=0
71098         ISL(IP)=0
71099         ISI(IP)=0
71100         IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
71101   320 CONTINUE
71102       ISLM=0
71103  
71104 C...Maximum virtuality of daughters.
71105       IF(IGM.LE.0) THEN
71106         DO 330 I=1,NPA
71107           IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
71108           P(N+I,5)=MIN(QMAX,PS(5))
71109           IR=IREF(N+I-NS)
71110           IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
71111           IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
71112   330   CONTINUE
71113       ELSE
71114         IF(MSTJ(43).LE.2) PEM=V(IM,2)
71115         IF(MSTJ(43).GE.3) PEM=P(IM,4)
71116         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
71117         P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
71118         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
71119       ENDIF
71120       DO 340 I=1,NEP
71121         PMSD(I)=P(N+I,5)
71122         IF(ISI(I).EQ.1) THEN
71123           IR=IREF(N+I-NS)
71124           IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
71125         ENDIF
71126         V(N+I,5)=P(N+I,5)**2
71127   340 CONTINUE
71128  
71129 C...Choose one of the daughters for evolution.
71130   350 INUM=0
71131       IF(NEP.EQ.1) INUM=1
71132       DO 360 I=1,NEP
71133         IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
71134   360 CONTINUE
71135       DO 370 I=1,NEP
71136         IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
71137           IR=IREF(N+I-NS)
71138           IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
71139         ENDIF
71140   370 CONTINUE
71141       IF(INUM.EQ.0) THEN
71142         RMAX=0D0
71143         DO 380 I=1,NEP
71144           IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
71145             RPM=P(N+I,5)/PMSD(I)
71146             IR=IREF(N+I-NS)
71147             IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
71148               RMAX=RPM
71149               INUM=I
71150             ENDIF
71151           ENDIF
71152   380   CONTINUE
71153       ENDIF
71154  
71155 C...Cancel choice of predetermined daughter already treated.
71156       INUM=MAX(1,INUM)
71157       INUMT=INUM
71158       IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
71159         IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
71160       ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
71161         IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
71162         IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
71163       ENDIF
71164  
71165 C...Store information on choice of evolving daughter.
71166       IEP(1)=N+INUM
71167       DO 390 I=2,NEP
71168         IEP(I)=IEP(I-1)+1
71169         IF(IEP(I).GT.N+NEP) IEP(I)=N+1
71170   390 CONTINUE
71171       DO 400 I=1,NEP
71172         KFL(I)=IABS(K(IEP(I),2))
71173   400 CONTINUE
71174       ITRY(INUM)=ITRY(INUM)+1
71175       IF(ITRY(INUM).GT.200) THEN
71176         CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
71177         IF(MSTU(21).GE.1) RETURN
71178       ENDIF
71179       Z=0.5D0
71180       IR=IREF(IEP(1)-NS)
71181       IF(KSH(IR).EQ.0) GOTO 450
71182       IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
71183  
71184 C...Check if evolution already predetermined for daughter.
71185       IPSPD=0
71186       IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
71187         IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
71188       ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
71189         IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
71190         IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
71191       ENDIF
71192       IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
71193         ISSET(INUM)=0
71194         IF(IPSPD.NE.0) ISSET(INUM)=1
71195       ENDIF
71196  
71197 C...Select side for interference with initial state partons.
71198       IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
71199         III=IEP(1)-NS-1
71200         ISII(III)=0
71201         IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
71202           ISII(III)=1
71203         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
71204           IF(PYR(0).GT.0.5D0) ISII(III)=1
71205         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
71206           ISII(III)=1
71207           IF(PYR(0).GT.0.5D0) ISII(III)=2
71208         ENDIF
71209       ENDIF
71210  
71211 C...Calculate allowed z range.
71212       IF(NEP.EQ.1) THEN
71213         PMED=PS(4)
71214       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
71215         PMED=P(IM,5)
71216       ELSE
71217         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
71218         IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
71219       ENDIF
71220       IF(MOD(MSTJ(43),2).EQ.1) THEN
71221         ZC=PMTH(2,21)/PMED
71222         ZCE=PMTH(2,22)/PMED
71223         IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
71224       ELSE
71225         ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
71226         IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
71227         PMTMPE=PMTH(2,22)
71228         IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
71229         ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
71230         IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
71231       ENDIF
71232       ZC=MIN(ZC,0.491D0)
71233       ZCE=MIN(ZCE,0.49991D0)
71234       IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
71235      &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
71236         P(IEP(1),5)=PMTH(1,IR)
71237         V(IEP(1),5)=P(IEP(1),5)**2
71238         GOTO 450
71239       ENDIF
71240  
71241 C...Integral of Altarelli-Parisi z kernel for QCD.
71242 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
71243       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
71244         FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
71245 C...QUARKONIA+++
71246 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
71247       ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
71248      &       (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
71249         FBR=6D0*LOG((1D0-ZC)/ZC)
71250 C...QUARKONIA---
71251       ELSEIF(MSTJ(49).EQ.0) THEN
71252         FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
71253         IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
71254  
71255 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
71256       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
71257         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
71258       ELSEIF(MSTJ(49).EQ.1) THEN
71259         FBR=(1D0-2D0*ZC)/3D0
71260         IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
71261  
71262 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
71263       ELSEIF(KFL(1).EQ.21) THEN
71264         FBR=6D0*MSTJ(45)*(0.5D0-ZC)
71265       ELSE
71266         FBR=2D0*LOG((1D0-ZC)/ZC)
71267       ENDIF
71268  
71269 C...Reset QCD probability for colourless.
71270       IF(ISCOL(IR).EQ.0) FBR=0D0
71271  
71272 C...Integral of Altarelli-Parisi kernel for photon emission.
71273       FBRE=0D0
71274       IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
71275         IF(KFL(1).LE.18) THEN
71276           FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
71277         ENDIF
71278         IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
71279       ENDIF
71280  
71281 C...Inner veto algorithm starts. Find maximum mass for evolution.
71282   410 PMS=V(IEP(1),5)
71283       IF(IGM.GE.0) THEN
71284         PM2=0D0
71285         DO 420 I=2,NEP
71286           PM=P(IEP(I),5)
71287           IRI=IREF(IEP(I)-NS)
71288           IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
71289           PM2=PM2+PM
71290   420   CONTINUE
71291         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
71292       ENDIF
71293  
71294 C...Select mass for daughter in QCD evolution.
71295       B0=27D0/6D0
71296       DO 430 IFF=4,MSTJ(45)
71297         IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
71298   430 CONTINUE
71299 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
71300       PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
71301 C...Already predetermined choice.
71302       IF(IPSPD.NE.0) THEN
71303         PMSQCD=P(IPSPD,5)**2
71304       ELSEIF(FBR.LT.1D-3) THEN
71305         PMSQCD=0D0
71306       ELSEIF(MSTJ(44).LE.0) THEN
71307         PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
71308       ELSEIF(MSTJ(44).EQ.1) THEN
71309         PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
71310       ELSE
71311         PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
71312       ENDIF
71313 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
71314       IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
71315       IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
71316       V(IEP(1),5)=PMSQCD
71317       MCE=1
71318  
71319 C...Select mass for daughter in QED evolution.
71320       IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
71321 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
71322         PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
71323         IF(FBRE.LT.1D-3) THEN
71324           PMSQED=0D0
71325         ELSE
71326           PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
71327      &    (PARU(101)*FBRE)))
71328         ENDIF
71329 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
71330         PMSQED=PMSQED+PMTH(1,IR)**2
71331         IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
71332      &  PMTH(2,IR)**2
71333         IF(PMSQED.GT.PMSQCD) THEN
71334           V(IEP(1),5)=PMSQED
71335           MCE=2
71336         ENDIF
71337       ENDIF
71338  
71339 C...Check whether daughter mass below cutoff.
71340       P(IEP(1),5)=SQRT(V(IEP(1),5))
71341       IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
71342         P(IEP(1),5)=PMTH(1,IR)
71343         V(IEP(1),5)=P(IEP(1),5)**2
71344         GOTO 450
71345       ENDIF
71346  
71347 C...Already predetermined choice of z, and flavour in g -> qqbar.
71348       IF(IPSPD.NE.0) THEN
71349         IPSGD1=K(IPSPD,4)
71350         IPSGD2=K(IPSPD,5)
71351         PMSGD1=P(IPSGD1,5)**2
71352         PMSGD2=P(IPSGD2,5)**2
71353         ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
71354      &  4D0*PMSGD1*PMSGD2))
71355         Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
71356      &  PMSGD1+PMSGD2)/ALAMPS
71357         Z=MAX(0.00001D0,MIN(0.99999D0,Z))
71358         IF(KFL(1).NE.21) THEN
71359           K(IEP(1),5)=21
71360         ELSE
71361           K(IEP(1),5)=IABS(K(IPSGD1,2))
71362         ENDIF
71363  
71364 C...Select z value of branching: q -> qgamma.
71365       ELSEIF(MCE.EQ.2) THEN
71366         Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
71367         IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
71368         K(IEP(1),5)=22
71369  
71370 C...QUARKONIA+++
71371 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
71372       ELSEIF(MSTJ(49).EQ.0.AND.
71373      &       (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
71374         Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
71375 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
71376         IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
71377         IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
71378         K(IEP(1),5)=21
71379 C...QUARKONIA---
71380  
71381 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
71382       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
71383         Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
71384 C...Only do z weighting when no ME correction afterwards.
71385         IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
71386         K(IEP(1),5)=21
71387       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
71388         Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
71389         IF(PYR(0).GT.0.5D0) Z=1D0-Z
71390         IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
71391         K(IEP(1),5)=21
71392       ELSEIF(MSTJ(49).NE.1) THEN
71393         Z=PYR(0)
71394         IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
71395         KFLB=1+INT(MSTJ(45)*PYR(0))
71396         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
71397         IF(PMQ.GE.1D0) GOTO 410
71398         IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
71399           IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
71400           PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
71401           IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
71402      &    .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
71403         ELSE
71404           IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
71405         ENDIF
71406         K(IEP(1),5)=KFLB
71407  
71408 C...Ditto for scalar gluon model.
71409       ELSEIF(KFL(1).NE.21) THEN
71410         Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
71411         K(IEP(1),5)=21
71412       ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
71413         Z=ZC+(1D0-2D0*ZC)*PYR(0)
71414         K(IEP(1),5)=21
71415       ELSE
71416         Z=ZC+(1D0-2D0*ZC)*PYR(0)
71417         KFLB=1+INT(MSTJ(45)*PYR(0))
71418         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
71419         IF(PMQ.GE.1D0) GOTO 410
71420         K(IEP(1),5)=KFLB
71421       ENDIF
71422  
71423 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
71424       IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
71425         IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
71426      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71427           IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
71428         ELSE
71429           PT2APP=Z*(1D0-Z)*V(IEP(1),5)
71430           IF(MSTJ(44).GE.4) PT2APP=PT2APP*
71431      &    (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
71432           IF(PT2APP.LT.PT2MIN) GOTO 410
71433           IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
71434         ENDIF
71435       ENDIF
71436  
71437 C...Check if z consistent with chosen m.
71438       IF(KFL(1).EQ.21) THEN
71439         IRGD1=IABS(K(IEP(1),5))
71440         IRGD2=IRGD1
71441       ELSE
71442         IRGD1=IR
71443         IRGD2=IABS(K(IEP(1),5))
71444       ENDIF
71445       IF(NEP.EQ.1) THEN
71446         PED=PS(4)
71447       ELSEIF(NEP.GE.3) THEN
71448         PED=P(IEP(1),4)
71449       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
71450         PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
71451       ELSE
71452         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
71453         IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
71454       ENDIF
71455       IF(MOD(MSTJ(43),2).EQ.1) THEN
71456         PMQTH3=0.5D0*PARJ(82)
71457         IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
71458         IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
71459         PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
71460         PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
71461         ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
71462      &  4D0*PMQ1*PMQ2)))
71463         ZH=1D0+PMQ1-PMQ2
71464       ELSE
71465         ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
71466         ZH=1D0
71467       ENDIF
71468       IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
71469      &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71470       ELSEIF(IPSPD.NE.0) THEN
71471       ELSE
71472         ZL=0.5D0*(ZH-ZD)
71473         ZU=0.5D0*(ZH+ZD)
71474         IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
71475       ENDIF
71476       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
71477      &(1D0-ZU)))
71478       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
71479  
71480 C...Width suppression for q -> q + g.
71481       IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
71482         IF(IGM.EQ.0) THEN
71483           EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
71484         ELSE
71485           EGLU=PMED*(1D0-Z)
71486         ENDIF
71487         CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
71488         IF(MSTJ(40).EQ.1) THEN
71489           IF(CHI.LT.PYR(0)) GOTO 410
71490         ELSEIF(MSTJ(40).EQ.2) THEN
71491           IF(1D0-CHI.LT.PYR(0)) GOTO 410
71492         ENDIF
71493       ENDIF
71494  
71495 C...Three-jet matrix element correction.
71496       IF(M3JC.GE.1) THEN
71497         WME=1D0
71498         WSHOW=1D0
71499  
71500 C...QED matrix elements: only for massless case so far.
71501         IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
71502           X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
71503           X2=1D0-V(IEP(1),5)/V(NS+1,5)
71504           X3=(1D0-X1)+(1D0-X2)
71505           KI1=K(IPA(INUM),2)
71506           KI2=K(IPA(3-INUM),2)
71507           QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
71508           QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
71509           WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
71510      &    QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
71511           WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
71512         ELSEIF(MCE.EQ.2) THEN
71513  
71514 C...QCD matrix elements, including mass effects.
71515         ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
71516           PS1ME=V(IEP(1),5)
71517           PM1ME=PMTH(1,IR)
71518           M3JCC=M3JC
71519           IF(IR.GE.31.AND.IGM.EQ.0) THEN
71520 C...QCD ME: original parton, first branching.
71521             PM2ME=PMTH(1,63-IR)
71522             ECMME=PS(5)
71523           ELSEIF(IR.GE.31) THEN
71524 C...QCD ME: original parton, subsequent branchings.
71525             PM2ME=PMTH(1,63-IR)
71526             PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
71527             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
71528           ELSEIF(K(IM,2).EQ.21) THEN
71529 C...QCD ME: secondary partons, first branching.
71530             PM2ME=PM1ME
71531             ZMME=V(IM,1)
71532             IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
71533             PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
71534      &      4D0*PS1ME*PM2ME**2))
71535             PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
71536      &      V(IM,5)
71537             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
71538             M3JCC=66
71539           ELSE
71540 C...QCD ME: secondary partons, subsequent branchings.
71541             PM2ME=PM1ME
71542             PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
71543             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
71544             M3JCC=66
71545           ENDIF
71546 C...Construct ME variables.
71547           R1ME=PM1ME/ECMME
71548           R2ME=PM2ME/ECMME
71549           X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
71550           X2=1D0+R2ME**2-PS1ME/ECMME**2
71551 C...Call ME, with right order important for two inequivalent showerers.
71552           IF(IR.EQ.IORD+30) THEN
71553             WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
71554           ELSE
71555             WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
71556           ENDIF
71557 C...Split up total ME when two radiating partons.
71558           ISPRAD=1
71559           IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
71560      &    (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
71561      &    (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
71562      &    (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
71563      &    (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
71564           IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
71565      &    MAX(1D-10,2D0-X1-X2)
71566 C...Evaluate shower rate to be compared with.
71567           WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
71568      &    MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
71569           IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
71570         ELSEIF(MSTJ(49).NE.1) THEN
71571  
71572 C...Toy model scalar theory matrix elements; no mass effects.
71573         ELSE
71574           X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
71575           X2=1D0-V(IEP(1),5)/V(NS+1,5)
71576           X3=(1D0-X1)+(1D0-X2)
71577           WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
71578           WME=X3**2
71579           IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
71580      &    PARJ(171)
71581         ENDIF
71582  
71583         IF(WME.LT.PYR(0)*WSHOW) GOTO 410
71584       ENDIF
71585  
71586 C...Impose angular ordering by rejection of nonordered emission.
71587       IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
71588         PEMAO=V(IM,1)*P(IM,4)
71589         IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
71590         IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
71591           MAOD=0
71592         ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
71593      &  .OR.MSTJ(42).EQ.7)) THEN
71594           MAOD=0
71595         ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
71596      &  .OR.MSTJ(42).EQ.6)) THEN
71597           MAOD=1
71598           PMDAO=PMTH(2,K(IEP(1),5))
71599           THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
71600         ELSE
71601           MAOD=1
71602           THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
71603           IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
71604      &    (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
71605         ENDIF
71606         MAOM=1
71607         IAOM=IM
71608   440   IF(K(IAOM,5).EQ.22) THEN
71609           IAOM=K(IAOM,3)
71610           IF(K(IAOM,3).LE.NS) MAOM=0
71611           IF(MAOM.EQ.1) GOTO 440
71612         ENDIF
71613         IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
71614           THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
71615           IF(THE2ID.LT.THE2IM) GOTO 410
71616         ENDIF
71617       ENDIF
71618  
71619 C...Impose user-defined maximum angle at first branching.
71620       IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
71621         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
71622           THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
71623           IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
71624         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
71625           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
71626           IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
71627         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
71628           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
71629           IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
71630         ENDIF
71631       ENDIF
71632  
71633 C...Impose angular constraint in first branching from interference
71634 C...with initial state partons.
71635       IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
71636         THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
71637         IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
71638           IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
71639         ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
71640           IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
71641         ENDIF
71642       ENDIF
71643  
71644 C...End of inner veto algorithm. Check if only one leg evolved so far.
71645   450 V(IEP(1),1)=Z
71646       ISL(1)=0
71647       ISL(2)=0
71648       IF(NEP.EQ.1) GOTO 490
71649       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
71650       DO 460 I=1,NEP
71651         IR=IREF(N+I-NS)
71652         IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
71653           IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
71654         ENDIF
71655   460 CONTINUE
71656  
71657 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
71658       IF(NEP.GE.3) THEN
71659         PMSUM=0D0
71660         DO 470 I=1,NEP
71661           PMSUM=PMSUM+P(N+I,5)
71662   470   CONTINUE
71663         IF(PMSUM.GE.PS(5)) GOTO 350
71664       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
71665         DO 480 I1=N+1,N+2
71666           IRDA=IREF(I1-NS)
71667           IF(KSH(IRDA).EQ.0) GOTO 480
71668           IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
71669           IF(IRDA.EQ.21) THEN
71670             IRGD1=IABS(K(I1,5))
71671             IRGD2=IRGD1
71672           ELSE
71673             IRGD1=IRDA
71674             IRGD2=IABS(K(I1,5))
71675           ENDIF
71676           I2=2*N+3-I1
71677           IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
71678             PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
71679           ELSE
71680             IF(I1.EQ.N+1) ZM=V(IM,1)
71681             IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
71682             PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
71683      &      4D0*V(N+1,5)*V(N+2,5))
71684             PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
71685      &      V(IM,5)
71686           ENDIF
71687           IF(MOD(MSTJ(43),2).EQ.1) THEN
71688             PMQTH3=0.5D0*PARJ(82)
71689             IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
71690             IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
71691             PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
71692             PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
71693             ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
71694      &      4D0*PMQ1*PMQ2)))
71695             ZH=1D0+PMQ1-PMQ2
71696           ELSE
71697             ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
71698             ZH=1D0
71699           ENDIF
71700           IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
71701      &    (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71702           ELSE
71703             ZL=0.5D0*(ZH-ZD)
71704             ZU=0.5D0*(ZH+ZD)
71705             IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
71706      &      ISSET(1).EQ.0) THEN
71707               ISL(1)=1
71708             ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
71709      &      ISSET(2).EQ.0) THEN
71710               ISL(2)=1
71711             ENDIF
71712           ENDIF
71713           IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
71714      &    ZL*(1D0-ZU)))
71715           IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
71716   480   CONTINUE
71717         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
71718           ISL(3-ISLM)=0
71719           ISLM=3-ISLM
71720         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
71721           ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
71722           ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
71723           IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
71724           IF(ISL(1).EQ.1) ISL(2)=0
71725           IF(ISL(1).EQ.0) ISLM=1
71726           IF(ISL(2).EQ.0) ISLM=2
71727         ENDIF
71728         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
71729       ENDIF
71730       IRD1=IREF(N+1-NS)
71731       IRD2=IREF(N+2-NS)
71732       IF(IGM.GT.0) THEN
71733         IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
71734      &  PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
71735           PMQ1=V(N+1,5)/V(IM,5)
71736           PMQ2=V(N+2,5)/V(IM,5)
71737           ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
71738      &    4D0*PMQ1*PMQ2)))
71739           ZH=1D0+PMQ1-PMQ2
71740           ZL=0.5D0*(ZH-ZD)
71741           ZU=0.5D0*(ZH+ZD)
71742           IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
71743         ENDIF
71744       ENDIF
71745  
71746 C...Accepted branch. Construct four-momentum for initial partons.
71747   490 MAZIP=0
71748       MAZIC=0
71749       IF(NEP.EQ.1) THEN
71750         P(N+1,1)=0D0
71751         P(N+1,2)=0D0
71752         P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
71753      &  P(N+1,5))))
71754         P(N+1,4)=P(IPA(1),4)
71755         V(N+1,2)=P(N+1,4)
71756       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
71757         PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
71758         P(N+1,1)=0D0
71759         P(N+1,2)=0D0
71760         P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
71761         P(N+1,4)=PED1
71762         P(N+2,1)=0D0
71763         P(N+2,2)=0D0
71764         P(N+2,3)=-P(N+1,3)
71765         P(N+2,4)=P(IM,5)-PED1
71766         V(N+1,2)=P(N+1,4)
71767         V(N+2,2)=P(N+2,4)
71768       ELSEIF(NEP.GE.3) THEN
71769 C...Rescale all momenta for energy conservation.
71770         LOOP=0
71771         PES=0D0
71772         PQS=0D0
71773         DO 510 I=1,NEP
71774           DO 500 J=1,4
71775             P(N+I,J)=P(IPA(I),J)
71776   500     CONTINUE
71777           PES=PES+P(N+I,4)
71778           PQS=PQS+P(N+I,5)**2/P(N+I,4)
71779   510   CONTINUE
71780   520   LOOP=LOOP+1
71781         FAC=(PS(5)-PQS)/(PES-PQS)
71782         PES=0D0
71783         PQS=0D0
71784         DO 540 I=1,NEP
71785           DO 530 J=1,3
71786             P(N+I,J)=FAC*P(N+I,J)
71787   530     CONTINUE
71788           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)
71789           V(N+I,2)=P(N+I,4)
71790           PES=PES+P(N+I,4)
71791           PQS=PQS+P(N+I,5)**2/P(N+I,4)
71792   540   CONTINUE
71793         IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
71794  
71795 C...Construct transverse momentum for ordinary branching in shower.
71796       ELSE
71797         ZM=V(IM,1)
71798         LOOPPT=0
71799   550   LOOPPT=LOOPPT+1
71800         PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
71801         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
71802         IF(PZM.LE.0D0) THEN
71803           PTS=0D0
71804         ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71805      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71806           PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
71807         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71808           PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
71809      &    ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
71810         ELSE
71811           PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
71812         ENDIF
71813         IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
71814           ZM=0.05D0+0.9D0*ZM
71815           GOTO 550
71816         ELSEIF(PTS.LT.0D0) THEN
71817           GOTO 280
71818         ENDIF
71819         PT=SQRT(MAX(0D0,PTS))
71820  
71821 C...Global statistics.
71822         MINT(353)=MINT(353)+1
71823         VINT(353)=VINT(353)+PT
71824         IF (MINT(353).EQ.1) VINT(358)=PT
71825  
71826 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
71827         HAZIP=0D0
71828         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
71829      &  .AND.IAU.NE.0) THEN
71830           IF(K(IGM,3).NE.0) MAZIP=1
71831           ZAU=V(IGM,1)
71832           IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
71833           IF(MAZIP.EQ.0) ZAU=0D0
71834           IF(K(IGM,2).NE.21) THEN
71835             HAZIP=2D0*ZAU/(1D0+ZAU**2)
71836           ELSE
71837             HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
71838           ENDIF
71839           IF(K(N+1,2).NE.21) THEN
71840             HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
71841           ELSE
71842             HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
71843           ENDIF
71844         ENDIF
71845  
71846 C...Find coefficient of azimuthal asymmetry due to soft gluon
71847 C...interference.
71848         HAZIC=0D0
71849         IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
71850      &  K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
71851           IF(K(IGM,3).NE.0) MAZIC=N+1
71852           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
71853           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71854      &    ZM.GT.0.5D0) MAZIC=N+2
71855           IF(K(IAU,2).EQ.22) MAZIC=0
71856           ZS=ZM
71857           IF(MAZIC.EQ.N+2) ZS=1D0-ZM
71858           ZGM=V(IGM,1)
71859           IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
71860           IF(MAZIC.EQ.0) ZGM=1D0
71861           IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
71862      &    SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
71863           HAZIC=MIN(0.95D0,HAZIC)
71864         ENDIF
71865       ENDIF
71866  
71867 C...Construct energies for ordinary branching in shower.
71868   560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
71869         IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71870      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71871           P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71872      &    PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71873         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71874           P(N+1,4)=PEM*V(IM,1)
71875         ELSE
71876           P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
71877      &    SQRT(PMLS)*ZM)/V(IM,5)
71878         ENDIF
71879  
71880 C...Already predetermined choice of phi angle or not
71881         PHI=PARU(2)*PYR(0)
71882         IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
71883           IPSPD=IP1+IM-NS-2
71884           IF(K(IPSPD,4).GT.0) THEN
71885             IPSGD1=K(IPSPD,4)
71886             IF(IM.EQ.NS+2) THEN
71887               PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71888             ELSE
71889               PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
71890             ENDIF
71891           ENDIF
71892         ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
71893           IPSPD=IP1+IM-NS-2
71894           IF(K(IPSPD,4).GT.0) THEN
71895             IPSGD1=K(IPSPD,4)
71896             PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
71897             THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
71898             CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
71899             CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
71900             PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71901             CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
71902           ENDIF
71903         ENDIF
71904  
71905 C...Construct momenta for ordinary branching in shower.
71906         P(N+1,1)=PT*COS(PHI)
71907         P(N+1,2)=PT*SIN(PHI)
71908         IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71909      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71910           P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71911      &    PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71912         ELSEIF(PZM.GT.0D0) THEN
71913           P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
71914      &    2D0*PEM*P(N+1,4))/PZM
71915         ELSE
71916           P(N+1,3)=0D0
71917         ENDIF
71918         P(N+2,1)=-P(N+1,1)
71919         P(N+2,2)=-P(N+1,2)
71920         P(N+2,3)=PZM-P(N+1,3)
71921         P(N+2,4)=PEM-P(N+1,4)
71922         IF(MSTJ(43).LE.2) THEN
71923           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
71924           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
71925         ENDIF
71926       ENDIF
71927  
71928 C...Rotate and boost daughters.
71929       IF(IGM.GT.0) THEN
71930         IF(MSTJ(43).LE.2) THEN
71931           BEX=P(IGM,1)/P(IGM,4)
71932           BEY=P(IGM,2)/P(IGM,4)
71933           BEZ=P(IGM,3)/P(IGM,4)
71934           GA=P(IGM,4)/P(IGM,5)
71935           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
71936      &    P(IM,4))
71937         ELSE
71938           BEX=0D0
71939           BEY=0D0
71940           BEZ=0D0
71941           GA=1D0
71942           GABEP=0D0
71943         ENDIF
71944         PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
71945         THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
71946         IF(PTIMB.GT.1D-4) THEN
71947           PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
71948         ELSE
71949           PHI=0D0
71950         ENDIF
71951         DO 570 I=N+1,N+2
71952           DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
71953      &    SIN(THE)*COS(PHI)*P(I,3)
71954           DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
71955      &    SIN(THE)*SIN(PHI)*P(I,3)
71956           DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
71957           DP(4)=P(I,4)
71958           DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
71959           DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
71960           P(I,1)=DP(1)+DGABP*BEX
71961           P(I,2)=DP(2)+DGABP*BEY
71962           P(I,3)=DP(3)+DGABP*BEZ
71963           P(I,4)=GA*(DP(4)+DBP)
71964   570   CONTINUE
71965       ENDIF
71966  
71967 C...Weight with azimuthal distribution, if required.
71968       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
71969         DO 580 J=1,3
71970           DPT(1,J)=P(IM,J)
71971           DPT(2,J)=P(IAU,J)
71972           DPT(3,J)=P(N+1,J)
71973   580   CONTINUE
71974         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
71975         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
71976         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
71977         DO 590 J=1,3
71978           DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
71979           DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
71980   590   CONTINUE
71981         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
71982         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
71983         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
71984           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
71985      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
71986           IF(MAZIP.NE.0) THEN
71987             IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
71988      &      GOTO 560
71989           ENDIF
71990           IF(MAZIC.NE.0) THEN
71991             IF(MAZIC.EQ.N+2) CAD=-CAD
71992             IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
71993      &      .LT.PYR(0)) GOTO 560
71994           ENDIF
71995         ENDIF
71996       ENDIF
71997  
71998 C...Azimuthal anisotropy due to interference with initial state partons.
71999       IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
72000      &K(N+2,2).EQ.21)) THEN
72001         III=IM-NS-1
72002         IF(ISII(III).GE.1) THEN
72003           IAZIID=N+1
72004           IF(K(N+1,2).NE.21) IAZIID=N+2
72005           IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
72006      &    P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
72007           THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
72008           IF(III.EQ.2) THEIID=PARU(1)-THEIID
72009           PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
72010           HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
72011           CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
72012           PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
72013           IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
72014           IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
72015      &    .LT.PYR(0)) GOTO 560
72016         ENDIF
72017       ENDIF
72018  
72019 C...Continue loop over partons that may branch, until none left.
72020       IF(IGM.GE.0) K(IM,1)=14
72021       N=N+NEP
72022       NEP=2
72023       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
72024         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
72025         IF(MSTU(21).GE.1) N=NS
72026         IF(MSTU(21).GE.1) RETURN
72027       ENDIF
72028       GOTO 290
72029  
72030 C...Set information on imagined shower initiator.
72031   600 IF(NPA.GE.2) THEN
72032         K(NS+1,1)=11
72033         K(NS+1,2)=94
72034         K(NS+1,3)=IP1
72035         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
72036         K(NS+1,4)=NS+2
72037         K(NS+1,5)=NS+1+NPA
72038         IIM=1
72039       ELSE
72040         IIM=0
72041       ENDIF
72042  
72043 C...Reconstruct string drawing information.
72044       DO 610 I=NS+1+IIM,N
72045         KQ=KCHG(PYCOMP(K(I,2)),2)
72046         IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
72047           K(I,1)=1
72048         ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
72049      &    IABS(K(I,2)).LE.18) THEN
72050           K(I,1)=1
72051         ELSEIF(K(I,1).LE.10) THEN
72052           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
72053           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
72054         ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
72055           ID1=MOD(K(I,4),MSTU(5))
72056           IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
72057           IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
72058      &    PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
72059           ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
72060           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
72061           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
72062           K(ID1,4)=K(ID1,4)+MSTU(5)*I
72063           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
72064           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
72065           K(ID2,5)=K(ID2,5)+MSTU(5)*I
72066         ELSE
72067           ID1=MOD(K(I,4),MSTU(5))
72068           ID2=ID1+1
72069           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
72070           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
72071           IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
72072             K(ID1,4)=K(ID1,4)+MSTU(5)*I
72073             K(ID1,5)=K(ID1,5)+MSTU(5)*I
72074           ELSE
72075             K(ID1,4)=0
72076             K(ID1,5)=0
72077           ENDIF
72078           K(ID2,4)=0
72079           K(ID2,5)=0
72080         ENDIF
72081   610 CONTINUE
72082  
72083 C...Transformation from CM frame.
72084       IF(NPA.EQ.1) THEN
72085         THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
72086         PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
72087         MSTU(33)=1
72088         CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
72089       ELSEIF(NPA.EQ.2) THEN
72090         BEX=PS(1)/PS(4)
72091         BEY=PS(2)/PS(4)
72092         BEZ=PS(3)/PS(4)
72093         GA=PS(4)/PS(5)
72094         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
72095      &  /(1D0+GA)-P(IPA(1),4))
72096         THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
72097      &  +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
72098         PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
72099         MSTU(33)=1
72100         CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
72101       ELSE
72102         CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
72103      &  PS(3)/PS(4))
72104         MSTU(33)=1
72105         CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
72106       ENDIF
72107  
72108 C...Decay vertex of shower.
72109       DO 630 I=NS+1,N
72110         DO 620 J=1,5
72111           V(I,J)=V(IP1,J)
72112   620   CONTINUE
72113   630 CONTINUE
72114  
72115 C...Delete trivial shower, else connect initiators.
72116       IF(N.LE.NS+NPA+IIM) THEN
72117         N=NS
72118       ELSE
72119         DO 640 IP=1,NPA
72120           K(IPA(IP),1)=14
72121           K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
72122           K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
72123           K(NS+IIM+IP,3)=IPA(IP)
72124           IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
72125           IF(K(NS+IIM+IP,1).NE.1) THEN
72126             K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
72127             K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
72128           ENDIF
72129   640   CONTINUE
72130       ENDIF
72131  
72132       RETURN
72133       END
72134  
72135 C*********************************************************************
72136  
72137 C...PYPTFS
72138 C...Generates pT-ordered timelike final-state parton showers.
72139  
72140 C...MODE defines how to find radiators and recoilers.
72141 C... = 0 : based on colour flow between undecayed partons.
72142 C... = 1 : for IPART <= NPARTD only consider primary partons,
72143 C...       whether decayed or not; else as above.
72144 C... = 2 : based on common history, whether decayed or not.
72145 C... = 3 : use (or create) MCT color information to shower partons
72146  
72147       SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
72148  
72149 C...Double precision and integer declarations.
72150       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72151       IMPLICIT INTEGER(I-N)
72152       INTEGER PYK,PYCHGE,PYCOMP
72153 C...Parameter statement to help give large particle numbers.
72154       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72155      &KEXCIT=4000000,KDIMEN=5000000)
72156 C...Parameter statement for maximum size of showers.
72157       PARAMETER (MAXNUR=1000)
72158 C...Commonblocks.
72159       COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
72160       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72161       COMMON/PYCTAG/NCT,MCT(4000,2)
72162       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72163       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72164       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72165       COMMON/PYINT1/MINT(400),VINT(400)
72166       SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
72167      &/PYINT1/
72168 C...Local arrays.
72169       DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
72170      &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
72171      &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
72172 C...Array to identify the initial-final dipoles
72173      &IRIF(2*MAXNUR),
72174      &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
72175 C...Statement functions.
72176       SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2-
72177      &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2
72178       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)
72179  
72180 C...Initial values. Check that valid system.
72181       PTGEN=0D0
72182       IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
72183      &MSTJ(41).NE.12) RETURN
72184       IF(NPART.LE.0) THEN
72185         CALL PYERRM(2,'(PYPTFS:) showering system too small')
72186         RETURN
72187       ENDIF
72188       PT2CMX=PTMAX**2
72189       IORD=1
72190  
72191 C...Mass thresholds and Lambda for QCD evolution.
72192       PMB=PMAS(5,1)
72193       PMC=PMAS(4,1)
72194       ALAM5=PARJ(81)
72195       ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
72196       ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
72197       PMBS=PMB**2
72198       PMCS=PMC**2
72199       ALAM5S=ALAM5**2
72200       ALAM4S=ALAM4**2
72201       ALAM3S=ALAM3**2
72202  
72203 C...Cutoff scale for QCD evolution. Starting pT2.
72204       NFLAV=MAX(0,MIN(5,MSTJ(45)))
72205       PT0C=0.5D0*PARJ(82)
72206       PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
72207  
72208 C...Parameters for QED evolution.
72209       AEM2PI=PARU(101)/PARU(2)
72210       PT0EQ=0.5D0*PARJ(83)
72211       PT0EL=0.5D0*PARJ(90)
72212  
72213 C...Reset. Remove irrelevant colour tags.
72214       NEVOL=0
72215       DO 100 J=1,4
72216         PSUM(J)=0D0
72217   100 CONTINUE
72218       DO 110 I=MINT(84)+1,N
72219         IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
72220           K(I,5)=0
72221           MCT(I,2)=0
72222         ENDIF
72223         IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
72224           K(I,4)=0
72225           MCT(I,1)=0
72226         ENDIF
72227   110 CONTINUE
72228       NPARTS=NPART
72229 
72230 C...Identify two hardest outgoing partons
72231 c.....Must do this all beforehand
72232       IFP1=0
72233       IFP2=0
72234       PTFP1=0D0
72235       PTFP2=0D0
72236       DO 115 IP=1,NPART
72237         I=IPART(IP)
72238 C...Haven't tested this yet -- should identify final-state partons
72239 C....in LHE files
72240 C...Mother must be one of the original partons
72241         IF(K(I,3).GT.MINT(84)+2) GOTO 115
72242 C...Removes resonance decay products
72243         IF(K(K(I,3),3).GT.0) GOTO 115
72244         IF(PTPART(IP).GT.PTFP1) THEN
72245            PTFP2=PTFP1
72246            IFP2=IFP1
72247            PTFP1=PTPART(IP)
72248            IFP1=I
72249         ELSEIF(PTPART(IP).GT.PTFP2) THEN
72250            IFP2=I
72251            PTFP2=PTPART(IP)
72252         ENDIF
72253  115  CONTINUE
72254 C...Begin loop to set up showering partons. Sum four-momenta.
72255       DO 230 IP=1,NPART
72256         I=IPART(IP)
72257         IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
72258           IF(K(I,1).GT.10) GOTO 230
72259         ELSEIF(K(I,3).GT.MINT(84)) THEN
72260           IF(K(I,3).GT.MINT(84)+2) GOTO 230
72261         ELSE
72262           IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
72263         ENDIF
72264         DO 120 J=1,4
72265           PSUM(J)=PSUM(J)+P(I,J)
72266   120   CONTINUE
72267  
72268 C...Find colour and charge, but skip diquarks.
72269         IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
72270         KCOL=PYK(I,12)
72271         KCHA=PYK(I,6)
72272  
72273 C...QUARKONIA++
72274         IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
72275           IF (MSTP(148).GE.1) THEN
72276 C...Temporary: force no radiation from quarkonia since not yet treated
72277             CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
72278      &          //' PYPTFS, switched off')
72279             CALL PYGIVE('MSTP(148)=0')
72280           ENDIF
72281           IF (MSTP(148).EQ.0) THEN
72282 C...Skip quarkonia if radiation switched off
72283             GOTO 230
72284           ENDIF
72285         ENDIF
72286 C...QUARKONIA--
72287  
72288 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
72289 C...(only intended for studying the effects of switching such rad on/off)
72290         IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
72291           GOTO 230
72292         ENDIF
72293  
72294 C...Either colour or anticolour charge radiates; for gluon both.
72295         DO 180 JSGCOL=1,-1,-2
72296           IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
72297             JCOL=4+(1-JSGCOL)/2
72298             JCOLR=9-JCOL
72299  
72300 C...Basic info about radiating parton.
72301             NEVOL=NEVOL+1
72302             IPOS(NEVOL)=I
72303             IFLG(NEVOL)=0
72304             ISCOL(NEVOL)=JSGCOL
72305             ISCHG(NEVOL)=0
72306             PTSCA(NEVOL)=PTPART(IP)
72307             IRIF(NEVOL)=0
72308  
72309 C...Begin search for colour recoiler when MODE = 0 or 1.
72310             IF(MODE.LE.1) THEN
72311 C...Find sister with matching anticolour to the radiating parton.
72312               IROLD=I
72313               IRNEW=K(IROLD,JCOL)/MSTU(5)
72314               MOVE=1
72315  
72316 C...Skip radiation off loose colour ends.
72317   130         IF(IRNEW.EQ.0) THEN
72318                 NEVOL=NEVOL-1
72319                 GOTO 180
72320  
72321 C...Optionally skip radiation on dipole to beam remnant.
72322               ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
72323                 NEVOL=NEVOL-1
72324                 GOTO 180
72325  
72326 C...For now always skip radiation on dipole to junction.
72327               ELSEIF(K(IRNEW,2).EQ.88) THEN
72328                 NEVOL=NEVOL-1
72329                 GOTO 180
72330  
72331 C...For MODE=1: if reached primary then done.
72332               ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
72333      &        IRNEW.LE.NPARTD) THEN
72334  
72335 C...If sister stable and points back then done.
72336               ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
72337      &        THEN
72338                 IF(K(IRNEW,1).LT.10) THEN
72339  
72340 C...If sister unstable then go to her daughter.
72341                 ELSE
72342                   IROLD=IRNEW
72343                   IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
72344                   MOVE=2
72345                   GOTO 130
72346                ENDIF
72347  
72348 C...If found mother then look for aunt.
72349               ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
72350      &        IROLD) THEN
72351                 IROLD=IRNEW
72352                 IRNEW=K(IROLD,JCOL)/MSTU(5)
72353                 GOTO 130
72354  
72355 C...If daughter stable then done.
72356               ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
72357      &        THEN
72358                 IF(K(IRNEW,1).LT.10) THEN
72359  
72360 C...If daughter unstable then go to granddaughter.
72361                 ELSE
72362                   IROLD=IRNEW
72363                   IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
72364                   MOVE=2
72365                   GOTO 130
72366                 ENDIF
72367  
72368 C...If daughter points to another daughter then done or move up.
72369               ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
72370      &        IROLD) THEN
72371                 IF(K(IRNEW,1).LT.10) THEN
72372                 ELSE
72373                   IROLD=IRNEW
72374                   IRNEW=K(IRNEW,JCOL)/MSTU(5)
72375                   MOVE=1
72376                   GOTO 130
72377                 ENDIF
72378               ENDIF
72379  
72380 C...Begin search for colour recoiler when MODE = 2.
72381             ELSEIF (MODE.EQ.2) THEN
72382               IROLD=I
72383               IRNEW=K(IROLD,JCOL)/MSTU(5)
72384   140         IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
72385 C...If no color partner found, pick at random among other primaries
72386 C...(e.g., when the color line is traced all the way to the beam)
72387                 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
72388                 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
72389               ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
72390 C...Step up to mother if radiating parton already branched.
72391                 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
72392                   IROLD=IRNEW
72393                   IRNEW=K(IROLD,JCOL)/MSTU(5)
72394                   GOTO 140
72395 C...Pick sister by history if no anticolour available.
72396                 ELSE
72397                   IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
72398                     IRNEW=IROLD-1
72399                   ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
72400      &            THEN
72401                     IRNEW=IROLD+1
72402 C...Last resort: pick at random among other primaries.
72403                   ELSE
72404                     ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
72405                     IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
72406                   ENDIF
72407                 ENDIF
72408               ENDIF
72409 C...Trace down if sister branched.
72410   150         IF(K(IRNEW,1).GT.10) THEN
72411                 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
72412 C...If no correct color-daughter found, swap.
72413                 IF (IRTMP.EQ.0) THEN
72414                   JCOL=9-JCOL
72415                   JCOLR=9-JCOLR
72416                   IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
72417                 ENDIF
72418                 IRNEW=IRTMP
72419                 GOTO 150
72420               ENDIF
72421             ELSEIF (MODE.EQ.3) THEN
72422 C...The following will add MCT colour tracing for unprepped events
72423 C...If not done, trace Les Houches colour tags for this dipole
72424               JCOLSV=JCOL
72425               IF (MCT(I,JCOL-3).EQ.0) THEN
72426 C...Special end code -1 : trace to color partner or 0, return in IEND
72427                 IEND=-1
72428                 CALL PYCTTR(I,JCOL,IEND)
72429 C...Clean up mother/daughter 'read' tags set by PYCTTR
72430                 JCOL=JCOLSV
72431                 DO 160 IR=1,N
72432                   K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
72433                   K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
72434                   MCT(IR,1)=0
72435                   MCT(IR,2)=0
72436   160           CONTINUE
72437               ELSE
72438                 IEND=0
72439                 DO 170 IR=1,N
72440                   IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
72441      &                IEND=IR
72442   170           CONTINUE
72443               ENDIF
72444 C...If no color partner, then we hit beam
72445               IF (IEND.LE.0) THEN
72446 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
72447                 IF (MSTP(72).LE.1) THEN
72448                   NEVOL=NEVOL-1
72449                   GOTO 180
72450                 ELSE
72451 C...Else try a random partner
72452                   ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
72453                   IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
72454                 ENDIF
72455               ELSE
72456 C...Else save recoiling colour partner
72457                 IRNEW=IEND
72458               ENDIF
72459  
72460             ENDIF
72461  
72462 C...Now found other end of colour dipole.
72463             IREC(NEVOL)=IRNEW
72464 C...Determine if this is an initial-final dipole
72465 c.....Check ALSO that mother is initial
72466 C...Recoiler originates from > 100
72467 C...Parton originates from < 100 (usually 7,8, etc.)
72468             IF(K(IRNEW,3).GT.MINT(84)) THEN
72469                IF(K(I,3).LE.MINT(84)+2) IRIF(NEVOL)=1
72470             ELSE
72471               IRIF(NEVOL)=0
72472             ENDIF
72473           ENDIF
72474   180   CONTINUE
72475  
72476 C...Also electrical charge may radiate; so far only quarks and leptons.
72477         IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
72478      &  IABS(K(I,2)).LE.18) THEN
72479  
72480 C...Basic info about radiating parton.
72481           NEVOL=NEVOL+1
72482           IPOS(NEVOL)=I
72483           IFLG(NEVOL)=0
72484           ISCOL(NEVOL)=0
72485           ISCHG(NEVOL)=KCHA
72486           PTSCA(NEVOL)=PTPART(IP)
72487           IRIF(NEVOL)=0
72488  
72489 C...Pick nearest (= smallest invariant mass) charged particle
72490 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
72491           IF(MODE.LE.1) THEN
72492             IRNEW=0
72493             PM2MIN=VINT(2)
72494             DO 190 IP2=1,NPART+N-MINT(53)
72495               IF(IP2.EQ.IP) GOTO 190
72496               IF(IP2.LE.NPART) THEN
72497                 I2=IPART(IP2)
72498                 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
72499                   IF(K(I2,1).GT.10) GOTO 190
72500                 ELSEIF(K(I2,3).GT.MINT(84)) THEN
72501                   IF(K(I2,3).GT.MINT(84)+2) GOTO 190
72502                 ELSE
72503                   IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
72504                 ENDIF
72505               ELSE
72506                 I2=MINT(53)+IP2-NPART
72507               ENDIF
72508               IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
72509               PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
72510      &        (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
72511               IF(PM2INV.LT.PM2MIN) THEN
72512                 IRNEW=I2
72513                 PM2MIN=PM2INV
72514               ENDIF
72515   190       CONTINUE
72516             IF(IRNEW.EQ.0) THEN
72517               NEVOL=NEVOL-1
72518               GOTO 230
72519             ENDIF
72520  
72521 C...Begin search for charge recoiler when MODE = 2.
72522           ELSE
72523             IROLD=I
72524 C...Pick sister by history; step up if parton already branched.
72525   200       IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
72526               IROLD=K(IROLD,3)
72527               GOTO 200
72528             ENDIF
72529             IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
72530               IRNEW=IROLD-1
72531             ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
72532               IRNEW=IROLD+1
72533 C...Last resort: pick at random among other primaries.
72534             ELSE
72535               ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
72536               IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
72537             ENDIF
72538 C...Trace down if sister branched.
72539   210       IF(K(IRNEW,1).GT.10) THEN
72540               DO 220 IR=IRNEW+1,N
72541                 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
72542                   IRNEW=IR
72543                   GOTO 210
72544                 ENDIF
72545   220         CONTINUE
72546             ENDIF
72547           ENDIF
72548           IREC(NEVOL)=IRNEW
72549         ENDIF
72550  
72551 C...End loop to set up showering partons. System invariant mass.
72552   230 CONTINUE
72553       IF(NEVOL.LE.0) RETURN
72554       IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
72555       PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
72556  
72557 C...Check if 3-jet matrix elements to be used.
72558       M3JC=0
72559       ALPHA=0.5D0
72560       NMESYS=0
72561       IF(MSTJ(47).GE.1) THEN
72562  
72563 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
72564         KFSRCE=0
72565         IPART1=K(IPART(1),3)
72566         IPART2=K(IPART(2),3)
72567   240   IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
72568           KFSRCE=IABS(K(IPART1,2))
72569         ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
72570           IPART1=K(IPART1,3)
72571           GOTO 240
72572         ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
72573           IPART2=K(IPART2,3)
72574           GOTO 240
72575         ENDIF
72576         ITYPES=0
72577         IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
72578         IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
72579         IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
72580         IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
72581         IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
72582         IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
72583         IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
72584         IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
72585  
72586 C...Identify two primary showerers.
72587         KFLA1=IABS(K(IPART(1),2))
72588         ITYPE1=0
72589         IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
72590         IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
72591         IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
72592         IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
72593         IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
72594         IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
72595         IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
72596         IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
72597         KFLA2=IABS(K(IPART(2),2))
72598         ITYPE2=0
72599         IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
72600         IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
72601         IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
72602         IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
72603         IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
72604         IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
72605         IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
72606         IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
72607  
72608 C...Order of showerers. Presence of gluino.
72609         ITYPMN=MIN(ITYPE1,ITYPE2)
72610         ITYPMX=MAX(ITYPE1,ITYPE2)
72611         IORD=1
72612         IF(ITYPE1.GT.ITYPE2) IORD=2
72613         IGLUI=0
72614         IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
72615  
72616 C...Require exactly two primary showerers for ME corrections.
72617         NPRIM=0
72618         IF(IPART1.GT.0) THEN
72619           DO 250 I=1,N
72620             IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
72621   250     CONTINUE
72622         ENDIF
72623         IF(NPRIM.NE.2) THEN
72624  
72625 C...Predetermined and default matrix element kinds.
72626         ELSEIF(MSTJ(38).NE.0) THEN
72627           M3JC=MSTJ(38)
72628           ALPHA=PARJ(80)
72629           MSTJ(38)=0
72630         ELSEIF(MSTJ(47).GE.6) THEN
72631           M3JC=MSTJ(47)
72632         ELSE
72633           ICLASS=1
72634           ICOMBI=4
72635  
72636 C...Vector/axial vector -> q + qbar; q -> q + V.
72637           IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
72638      &    ITYPES.EQ.3)) THEN
72639             ICLASS=2
72640             IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
72641               ICOMBI=1
72642             ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
72643      &      K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
72644 C...gamma*/Z0: assume e+e- initial state if unknown.
72645               EI=-1D0
72646               IF(KFSRCE.EQ.23) THEN
72647                 IANNFL=IPART1
72648                 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
72649                 IF(IANNFL.GT.0) THEN
72650                   IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
72651                 ENDIF
72652                 IF(IANNFL.NE.0) THEN
72653                   KANNFL=IABS(K(IANNFL,2))
72654                   IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
72655                 ENDIF
72656               ENDIF
72657               AI=SIGN(1D0,EI+0.1D0)
72658               VI=AI-4D0*EI*PARU(102)
72659               EF=KCHG(KFLA1,1)/3D0
72660               AF=SIGN(1D0,EF+0.1D0)
72661               VF=AF-4D0*EF*PARU(102)
72662               XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
72663               SH=PSUM(5)**2
72664               SQMZ=PMAS(23,1)**2
72665               SQWZ=PSUM(5)*PMAS(23,2)
72666               SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
72667               VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
72668      &        (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
72669               AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
72670               ICOMBI=3
72671               ALPHA=VECT/(VECT+AXIV)
72672             ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
72673               ICOMBI=4
72674             ENDIF
72675 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
72676           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
72677             ICLASS=2
72678           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
72679      &    ITYPES.EQ.1)) THEN
72680             ICLASS=3
72681  
72682 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
72683           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
72684             ICLASS=4
72685             IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
72686               ICOMBI=1
72687             ELSEIF(KFSRCE.EQ.36) THEN
72688               ICOMBI=2
72689             ENDIF
72690           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
72691      &    ITYPES.EQ.1)) THEN
72692             ICLASS=5
72693  
72694 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
72695           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
72696      &    ITYPES.EQ.3)) THEN
72697             ICLASS=6
72698           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
72699      &    ITYPES.EQ.2)) THEN
72700             ICLASS=7
72701           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
72702             ICLASS=8
72703           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
72704      &    ITYPES.EQ.2)) THEN
72705             ICLASS=9
72706  
72707 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
72708           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
72709      &    ITYPES.EQ.5)) THEN
72710             ICLASS=10
72711           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
72712      &    ITYPES.EQ.2)) THEN
72713             ICLASS=11
72714           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
72715      &    ITYPES.EQ.1)) THEN
72716             ICLASS=12
72717  
72718 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
72719           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
72720             ICLASS=13
72721           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
72722      &    ITYPES.EQ.2)) THEN
72723             ICLASS=14
72724           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
72725      &    ITYPES.EQ.1)) THEN
72726             ICLASS=15
72727  
72728 C...g -> ~g + ~g (eikonal approximation).
72729           ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
72730             ICLASS=16
72731           ENDIF
72732 
72733 C...Revert to eikonal approximation for gluon in final state.
72734           IF(KFLA1.EQ.21.OR.KFLA2.EQ.21) ICLASS=1 
72735 
72736           M3JC=5*ICLASS+ICOMBI
72737         ENDIF
72738  
72739 C...Store pair that together define matrix element treatment.
72740         IF(M3JC.NE.0) THEN
72741           NMESYS=1
72742           MESYS(NMESYS,0)=M3JC
72743           MESYS(NMESYS,1)=IPART(1)
72744           MESYS(NMESYS,2)=IPART(2)
72745         ENDIF
72746  
72747 C...Store qqbar or l+l- pairs for QED radiation.
72748         IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
72749           NMESYS=NMESYS+1
72750           MESYS(NMESYS,0)=101
72751           IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
72752           MESYS(NMESYS,1)=IPART(1)
72753           MESYS(NMESYS,2)=IPART(2)
72754         ENDIF
72755  
72756 C...Store other qqbar/l+l- pairs from g/gamma branchings.
72757         DO 290 I1=1,N
72758           IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
72759           I1M=K(I1,3)
72760   260     IF(I1M.GT.0) THEN
72761             IF(K(I1M,2).EQ.K(I1,2)) THEN
72762               I1M=K(I1M,3)
72763               GOTO 260
72764             ENDIF
72765           ENDIF
72766 C...Move up this check to avoid out-of-bounds.
72767           IF(I1M.EQ.0) GOTO 290
72768           IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
72769           DO 280 I2=I1+1,N
72770             IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
72771             I2M=K(I2,3)
72772   270       IF(I2M.GT.0) THEN
72773               IF(K(I2M,2).EQ.K(I2,2)) THEN
72774                 I2M=K(I2M,3)
72775                 GOTO 270
72776               ENDIF
72777             ENDIF
72778             IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
72779               NMESYS=NMESYS+1
72780               MESYS(NMESYS,0)=66
72781               MESYS(NMESYS,1)=I1
72782               MESYS(NMESYS,2)=I2
72783               NMESYS=NMESYS+1
72784               MESYS(NMESYS,0)=102
72785               MESYS(NMESYS,1)=I1
72786               MESYS(NMESYS,2)=I2
72787             ENDIF
72788   280     CONTINUE
72789   290   CONTINUE
72790       ENDIF
72791  
72792 C..Loopback point for counting number of emissions.
72793       NGEN=0
72794   300 NGEN=NGEN+1
72795  
72796 C...Begin loop to evolve all existing partons, if required.
72797   310 IMX=0
72798       PT2MX=0D0
72799       DO 380 IEVOL=1,NEVOL
72800         IF(IFLG(IEVOL).EQ.0) THEN
72801  
72802 C...Basic info on radiator and recoil.
72803           I=IPOS(IEVOL)
72804           IR=IREC(IEVOL)
72805           SHT=SHAT(I,IR)
72806           PM2I=P(I,5)**2
72807           PM2R=P(IR,5)**2
72808  
72809 C...Skip any particles that are "turned off"
72810           IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380
72811 
72812 C...Invariant mass of "dipole".Starting value for pT evolution.
72813           SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72814           PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
72815 C.........else if IREC is potentially a soft gluon from the initial state
72816 C...Change the showering scale for initial-final dipoles
72817           IF(IRIF(IEVOL).EQ.1) THEN
72818 C...Make sure the recoiler is a different parton
72819             IF(I.EQ.IFP1) THEN
72820               IR=IFP2
72821             ELSE
72822               IR=IFP1
72823             ENDIF
72824 C...Recalculate quantities for new recoiler
72825             PM2R=P(IR,5)**2
72826             SHT=SHAT(I,IR)            
72827             SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72828             PT2NEW=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
72829 C...If new pT2 is less than original, then don't change
72830             IF(PT2NEW.LE.PT2) THEN
72831               IR=IREC(IEVOL)
72832               PM2R=P(IR,5)**2
72833               SHT=SHAT(I,IR)            
72834               SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72835             ELSE
72836               PT2=PT2NEW
72837             ENDIF
72838 C...Once the max scale is below threshold, turn off
72839 C           IF(PT2NEW.EQ.PT2CMX) IRIF(IEVOL)=0
72840           ENDIF
72841 
72842 
72843 C...Case of evolution by QCD branching.
72844           IF(ISCOL(IEVOL).NE.0) THEN
72845  
72846 C...Parton-by-parton maximum scale from initial conditions.
72847           IF(MSTP(72).EQ.0) THEN
72848             DO 320 IPRT=1,NPARTS
72849               IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
72850   320       CONTINUE
72851           ENDIF
72852  
72853 C...If kinematically impossible then do not evolve.
72854             IF(PT2.LT.PT2CMN) THEN
72855               IFLG(IEVOL)=-1
72856               GOTO 380
72857             ENDIF
72858  
72859 C...Check if part of system for which ME corrections should be applied.
72860             IMESYS=0
72861             DO 330 IME=1,NMESYS
72862               IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72863      &        MESYS(IME,0).LT.100) IMESYS=IME
72864   330       CONTINUE
72865  
72866 C...Special flag for colour octet states.
72867 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
72868             MOCT=0
72869             KC = PYCOMP(K(I,2))
72870             IF(K(I,2).EQ.21) THEN
72871               MOCT=1
72872             ELSEIF(KCHG(KC,2).EQ.2) THEN
72873               MOCT=2
72874             ENDIF
72875 C...QUARKONIA++
72876             IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
72877      &          IABS(K(I,2)).LE.9910555) MOCT=2
72878 C...QUARKONIA--
72879  
72880  
72881 C...Upper estimate for matrix element weighting and colour factor.
72882 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
72883             WTPSGL=2D0
72884             COLFAC=4D0/3D0
72885             IF(MOCT.GE.1) COLFAC=3D0/2D0
72886             IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
72887             WTPSQQ=0.5D0*0.5D0*NFLAV
72888  
72889 C...Determine overestimated z range: switch at c and b masses.
72890   340       IZRG=1
72891             PT2MNE=PT2CMN
72892             B0=27D0/6D0
72893             ALAMS=ALAM3S
72894             IF(PT2.GT.1.01D0*PMCS) THEN
72895               IZRG=2
72896               PT2MNE=PMCS
72897               B0=25D0/6D0
72898               ALAMS=ALAM4S
72899             ENDIF
72900             IF(PT2.GT.1.01D0*PMBS) THEN
72901               IZRG=3
72902               PT2MNE=PMBS
72903               B0=23D0/6D0
72904               ALAMS=ALAM5S
72905             ENDIF
72906             ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
72907             IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
72908  
72909 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
72910             EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
72911             EVCOEF=EVEMGL
72912             IF(MOCT.EQ.1) THEN
72913               EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
72914               EVCOEF=EVCOEF+EVEMQQ
72915             ENDIF
72916  
72917 C...Pick pT2 (in overestimated z range).
72918   350       PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
72919  
72920 C...Loopback if crossed c/b mass thresholds.
72921             IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
72922               PT2=PMBS
72923               GOTO 340
72924             ENDIF
72925             IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
72926               PT2=PMCS
72927               GOTO 340
72928             ENDIF
72929  
72930 C...Finish if below lower cutoff.
72931             IF(PT2.LT.PT2CMN) THEN
72932               IFLG(IEVOL)=-1
72933               GOTO 380
72934             ENDIF
72935 
72936 C...Check if we switch back to original "small" dipole
72937 C.....Should only have to check once if IR != IREC(IEVOL)
72938 C...IR has changed and IRIF flag is set and pT2 is "small"
72939             IF(IR.NE.IREC(IEVOL).AND.IRIF(IEVOL).NE.0.AND.
72940      $        PT2.LT.0.25D0*SHAT(I,IREC(IEVOL))) THEN
72941 C...Switch back to original recoiler and recalculate
72942               IR=IREC(IEVOL)
72943               PM2R=P(IR,5)**2
72944               SHT=SHAT(I,IR)            
72945               SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72946             ENDIF
72947 
72948  
72949 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
72950 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
72951             IFLAG=1
72952             IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
72953  
72954 C...Pick z: dz/(1-z) or dz.
72955             IF(IFLAG.EQ.1) THEN
72956               Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72957             ELSE
72958               Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
72959             ENDIF
72960  
72961 C...Loopback if outside allowed range for given pT2.
72962             ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72963             IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72964             IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
72965             PM2=PM2I+PT2/(Z*(1D0-Z))
72966             IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
72967  
72968 C...No weighting for primary partons; to be done later on.
72969             IF(IMESYS.GT.0) THEN
72970  
72971 C...Weighting of q->qg/X->Xg branching.
72972             ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
72973               IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
72974  
72975 C...Weighting of g->gg branching.
72976             ELSEIF(IFLAG.EQ.1) THEN
72977               IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
72978  
72979 C...Flavour choice and weighting of g->qqbar branching.
72980             ELSE
72981               KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
72982               PMQ=PMAS(KFQ,1)
72983               ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72984               WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
72985               IF(WTME.LT.PYR(0)) GOTO 350
72986               IFLAG=10+KFQ
72987             ENDIF
72988  
72989 C...Case of evolution by QED branching.
72990           ELSEIF(ISCHG(IEVOL).NE.0) THEN
72991  
72992 C...If kinematically impossible then do not evolve.
72993             PT2EMN=PT0EQ**2
72994             IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
72995             IF(PT2.LT.PT2EMN) THEN
72996               IFLG(IEVOL)=-1
72997               GOTO 380
72998             ENDIF
72999  
73000 C...Check if part of system for which ME corrections should be applied.
73001            IMESYS=0
73002             DO 360 IME=1,NMESYS
73003               IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
73004      &        MESYS(IME,0).GT.100) IMESYS=IME
73005   360      CONTINUE
73006  
73007 C...Charge. Matrix element weighting factor.
73008             CHG=ISCHG(IEVOL)/3D0
73009             WTPSGA=2D0
73010  
73011 C...Determine overestimated z range. Find evolution coefficient.
73012             ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
73013             IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
73014             EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
73015  
73016 C...Pick pT2 (in overestimated z range).
73017   370       PT2=PT2*PYR(0)**(1D0/EVCOEF)
73018  
73019 C...Finish if below lower cutoff.
73020             IF(PT2.LT.PT2EMN) THEN
73021               IFLG(IEVOL)=-1
73022               GOTO 380
73023             ENDIF
73024  
73025 C...Pick z: dz/(1-z).
73026             Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
73027  
73028 C...Loopback if outside allowed range for given pT2.
73029             ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
73030             IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
73031             IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
73032             PM2=PM2I+PT2/(Z*(1D0-Z))
73033             IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
73034  
73035 C...Weighting by branching kernel, except if ME weighting later.
73036             IF(IMESYS.EQ.0) THEN
73037               IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
73038             ENDIF
73039             IFLAG=3
73040           ENDIF
73041  
73042 C...Save acceptable branching.
73043 C...If the recoiler changed, update
73044           IREC(IEVOL)=IR
73045           IFLG(IEVOL)=IFLAG
73046           IMESAV(IEVOL)=IMESYS
73047           PT2SAV(IEVOL)=PT2
73048           ZSAV(IEVOL)=Z
73049           SHTSAV(IEVOL)=SHT            
73050         ENDIF
73051  
73052 C...Check if branching has highest pT.
73053         IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
73054           IMX=IEVOL
73055           PT2MX=PT2SAV(IEVOL)
73056         ENDIF
73057   380 CONTINUE
73058  
73059 C...Finished if no more branchings to be done.
73060       IF(IMX.EQ.0) GOTO 520
73061  
73062 C...Restore info on hardest branching to be processed.
73063       I=IPOS(IMX)
73064       IR=IREC(IMX)
73065       KCOL=ISCOL(IMX)
73066       KCHA=ISCHG(IMX)
73067       IMESYS=IMESAV(IMX)
73068       PT2=PT2SAV(IMX)
73069       Z=ZSAV(IMX)
73070       SHT=SHTSAV(IMX)
73071       PM2I=P(I,5)**2
73072       PM2R=P(IR,5)**2
73073       PM2=PM2I+PT2/(Z*(1D0-Z))
73074 
73075  
73076 C...Special flag for colour octet states.
73077       MOCT=0
73078       KC = PYCOMP(K(I,2))
73079       IF(K(I,2).EQ.21) THEN
73080         MOCT=1
73081       ELSEIF(KCHG(KC,2).EQ.2) THEN
73082         MOCT=2
73083       ENDIF
73084 C...QUARKONIA++
73085       IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
73086      &    IABS(K(I,2)).LE.9910555) MOCT=2
73087 C...QUARKONIA--
73088  
73089 C...Restore further info for g->qqbar branching.
73090       KFQ=0
73091       IF(IFLG(IMX).GT.10) THEN
73092         KFQ=IFLG(IMX)-10
73093         PMQ=PMAS(KFQ,1)
73094         ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
73095       ENDIF
73096  
73097 C...For branching g include azimuthal asymmetries from polarization.
73098       ASYPOL=0D0
73099       IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
73100 C...Trace grandmother via intermediate recoil copies.
73101         KFGM=0
73102         IM=I
73103   390   IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
73104      &  K(IM,3).GT.0) THEN
73105           IM=K(IM,3)
73106           IF(IM.GT.MINT(84)) GOTO 390
73107         ENDIF
73108         IGM=K(IM,3)
73109         IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
73110      &  KFGM=IABS(K(IGM,2))
73111 C...Define approximate energy sharing by identifying aunt.
73112         IAU=IM+1
73113         IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
73114         IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
73115           ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
73116 C...Coefficient from gluon production.
73117           IF(KFGM.LE.6) THEN
73118             ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
73119           ELSE
73120             ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
73121           ENDIF
73122 C...Coefficient from gluon decay.
73123           IF(KFQ.EQ.0) THEN
73124             ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
73125           ELSE
73126             ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
73127           ENDIF
73128         ENDIF
73129       ENDIF
73130  
73131 C...Create new slots for branching products and recoil.
73132       INEW=N+1
73133       IGNEW=N+2
73134       IRNEW=N+3
73135       N=N+3
73136 
73137 C...Update location of hard final-state parton
73138       IF(I.EQ.IFP1) THEN
73139          IFP1=INEW
73140       ELSEIF(I.EQ.IFP2) THEN
73141          IFP2=INEW
73142       ENDIF
73143 C...Update location of recoiler
73144       IF(IR.EQ.IFP1) THEN
73145          IFP1=IRNEW
73146       ELSEIF(IR.EQ.IFP2) THEN
73147          IFP2=IRNEW
73148       ENDIF
73149 
73150  
73151 C...Set status, flavour and mother of new ones.
73152       K(INEW,1)=K(I,1)
73153       K(IGNEW,1)=3
73154       IF(KCHA.NE.0)  K(IGNEW,1)=1
73155       K(IRNEW,1)=K(IR,1)
73156       IF(KFQ.EQ.0) THEN
73157         K(INEW,2)=K(I,2)
73158         K(IGNEW,2)=21
73159         IF(KCHA.NE.0)  K(IGNEW,2)=22
73160       ELSE
73161         K(INEW,2)=-ISIGN(KFQ,KCOL)
73162         K(IGNEW,2)=-K(INEW,2)
73163       ENDIF
73164       K(IRNEW,2)=K(IR,2)
73165       K(INEW,3)=I
73166       K(IGNEW,3)=I
73167       K(IRNEW,3)=IR
73168  
73169 C...Find rest frame and angles of branching+recoil.
73170       DO 400 J=1,5
73171         P(INEW,J)=P(I,J)
73172         P(IGNEW,J)=0D0
73173         P(IRNEW,J)=P(IR,J)
73174   400 CONTINUE
73175       BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
73176       BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
73177       BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
73178       CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
73179       PHI=PYANGL(P(INEW,1),P(INEW,2))
73180       THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
73181  
73182 C...Derive kinematics of branching: generics (like g->gg).
73183       DO 410 J=1,4
73184         P(INEW,J)=0D0
73185         P(IRNEW,J)=0D0
73186   410 CONTINUE
73187       PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
73188       PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
73189       PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
73190       PTCOR=SQRT(MAX(0D0,PT2COR))
73191       PZN=(PEM**2*Z-0.5D0*PM2)/PZM
73192       PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
73193 C...Specific kinematics reduction for q->qg with m_q > 0.
73194       IF(MOCT.NE.1) THEN
73195         PTCOR=(1D0-PM2I/PM2)*PTCOR
73196         PZN=PZN+PM2I*PZG/PM2
73197         PZG=(1D0-PM2I/PM2)*PZG
73198 C...Specific kinematics reduction for g->qqbar with m_q > 0.
73199       ELSEIF(KFQ.NE.0) THEN
73200         P(INEW,5)=PMQ
73201         P(IGNEW,5)=PMQ
73202         PTCOR=ROOTQQ*PTCOR
73203         PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
73204         PZG=PZM-PZN
73205       ENDIF
73206  
73207 C...Pick phi and construct kinematics of branching.
73208   420 PHIROT=PARU(2)*PYR(0)
73209       P(INEW,1)=PTCOR*COS(PHIROT)
73210       P(INEW,2)=PTCOR*SIN(PHIROT)
73211       P(INEW,3)=PZN
73212       P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
73213       P(IGNEW,1)=-P(INEW,1)
73214       P(IGNEW,2)=-P(INEW,2)
73215       P(IGNEW,3)=PZG
73216       P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
73217       P(IRNEW,1)=0D0
73218       P(IRNEW,2)=0D0
73219       P(IRNEW,3)=-PZM
73220       P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
73221  
73222 C...Boost branching system to lab frame.
73223       CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
73224  
73225 C...Renew choice of phi angle according to polarization asymmetry.
73226       IF(ABS(ASYPOL).GT.1D-3) THEN
73227         DO 430 J=1,3
73228           DPT(1,J)=P(I,J)
73229           DPT(2,J)=P(IAU,J)
73230           DPT(3,J)=P(INEW,J)
73231   430   CONTINUE
73232         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
73233         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
73234         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
73235         DO 440 J=1,3
73236           DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
73237           DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
73238   440   CONTINUE
73239         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
73240         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
73241         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
73242           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
73243      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
73244           IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
73245      &    GOTO 420
73246         ENDIF
73247       ENDIF
73248  
73249 C...Matrix element corrections for primary partons when requested.
73250       IF(IMESYS.GT.0) THEN
73251         M3JC=MESYS(IMESYS,0)
73252  
73253 C...Identify recoiling partner and set up three-body kinematics.
73254         IRP=MESYS(IMESYS,1)
73255         IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
73256         IF(IRP.EQ.IR) IRP=IRNEW
73257         DO 450 J=1,4
73258           PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
73259   450   CONTINUE
73260         PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
73261      &  PSUM(3)**2))
73262         X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
73263      &  PSUM(3)*P(INEW,3))/PSUM(5)**2
73264         X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
73265      &  PSUM(3)*P(IRP,3))/PSUM(5)**2
73266         X3=2D0-X1-X2
73267         R1ME=P(INEW,5)/PSUM(5)
73268         R2ME=P(IRP,5)/PSUM(5)
73269  
73270 C...Matrix elements for gluon emission.
73271         IF(M3JC.LT.100) THEN
73272  
73273 C...Call ME, with right order important for two inequivalent showerers.
73274           IF(MESYS(IMESYS,IORD).EQ.I) THEN
73275             WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
73276           ELSE
73277             WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
73278           ENDIF
73279  
73280 C...Split up total ME when two radiating partons.
73281           ISPRAD=1
73282           IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
73283      &    .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
73284      &    .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
73285           IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
73286      &    MAX(1D-10,2D0-X1-X2)
73287  
73288 C...Evaluate shower rate.
73289           WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
73290      &    MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
73291           IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
73292  
73293 C...Matrix elements for photon emission: still rather primitive.
73294         ELSE
73295  
73296 C...For generic charge combination currently only massless expression.
73297           IF(M3JC.EQ.101) THEN
73298             CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
73299             CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
73300             WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
73301             WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
73302  
73303 C...For flavour neutral system assume vector source and include masses.
73304           ELSE
73305             WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
73306      &      1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
73307             WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
73308      &      MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
73309           ENDIF
73310         ENDIF
73311  
73312 C...Perform weighting with W_ME/W_PS.
73313         IF(WME.LT.PYR(0)*WPS) THEN
73314           N=N-3
73315           IFLG(IMX)=0
73316           PT2CMX=PT2
73317           GOTO 310
73318         ENDIF
73319       ENDIF
73320  
73321 C...Now for sure accepted branching. Save highest pT.
73322       IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
73323  
73324 C...Update status for obsolete ones. Bookkeep the moved original parton
73325 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
73326 C...Do not bookkeep radiated photon, since it cannot radiate further.
73327       K(I,1)=K(I,1)+10
73328       K(IR,1)=K(IR,1)+10
73329       DO 460 IP=1,NPART
73330         IF(IPART(IP).EQ.I) IPART(IP)=INEW
73331         IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
73332   460 CONTINUE
73333       IF(KCHA.EQ.0) THEN
73334         NPART=NPART+1
73335         IPART(NPART)=IGNEW
73336       ENDIF
73337  
73338 C...Initialize colour flow of branching.
73339 C...Use both old and new style colour tags for flexibility.
73340       K(INEW,4)=0
73341       K(IGNEW,4)=0
73342       K(INEW,5)=0
73343       K(IGNEW,5)=0
73344       JCOLP=4+(1-KCOL)/2
73345       JCOLN=9-JCOLP
73346       MCT(INEW,1)=0
73347       MCT(INEW,2)=0
73348       MCT(IGNEW,1)=0
73349       MCT(IGNEW,2)=0
73350       MCT(IRNEW,1)=0
73351       MCT(IRNEW,2)=0
73352  
73353 C...Trivial colour flow for l->lgamma and q->qgamma.
73354       IF(IABS(KCHA).EQ.3) THEN
73355         K(I,4)=INEW
73356         K(I,5)=IGNEW
73357       ELSEIF(KCHA.NE.0) THEN
73358         IF(K(I,4).NE.0) THEN
73359           K(I,4)=K(I,4)+INEW
73360           K(INEW,4)=MSTU(5)*I
73361           MCT(INEW,1)=MCT(I,1)
73362         ENDIF
73363         IF(K(I,5).NE.0) THEN
73364           K(I,5)=K(I,5)+INEW
73365           K(INEW,5)=MSTU(5)*I
73366           MCT(INEW,2)=MCT(I,2)
73367         ENDIF
73368  
73369 C...Set colour flow for q->qg and g->gg.
73370       ELSEIF(KFQ.EQ.0) THEN
73371         K(I,JCOLP)=K(I,JCOLP)+IGNEW
73372         K(IGNEW,JCOLP)=MSTU(5)*I
73373         K(INEW,JCOLP)=MSTU(5)*IGNEW
73374         K(IGNEW,JCOLN)=MSTU(5)*INEW
73375         MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
73376         NCT=NCT+1
73377         MCT(INEW,JCOLP-3)=NCT
73378         MCT(IGNEW,JCOLN-3)=NCT
73379         IF(MOCT.GE.1) THEN
73380           K(I,JCOLN)=K(I,JCOLN)+INEW
73381           K(INEW,JCOLN)=MSTU(5)*I
73382           MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
73383         ENDIF
73384  
73385 C...Set colour flow for g->qqbar.
73386       ELSE
73387         K(I,JCOLN)=K(I,JCOLN)+INEW
73388         K(INEW,JCOLN)=MSTU(5)*I
73389         K(I,JCOLP)=K(I,JCOLP)+IGNEW
73390         K(IGNEW,JCOLP)=MSTU(5)*I
73391         MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
73392         MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
73393       ENDIF
73394  
73395 C...Daughter info for colourless recoiling parton.
73396       IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
73397         K(IR,4)=IRNEW
73398         K(IR,5)=IRNEW
73399         K(IRNEW,4)=0
73400         K(IRNEW,5)=0
73401  
73402 C...Colour of recoiling parton sails through unchanged.
73403       ELSE
73404         IF(K(IR,4).NE.0) THEN
73405           K(IR,4)=K(IR,4)+IRNEW
73406           K(IRNEW,4)=MSTU(5)*IR
73407           MCT(IRNEW,1)=MCT(IR,1)
73408         ENDIF
73409         IF(K(IR,5).NE.0) THEN
73410           K(IR,5)=K(IR,5)+IRNEW
73411           K(IRNEW,5)=MSTU(5)*IR
73412           MCT(IRNEW,2)=MCT(IR,2)
73413         ENDIF
73414       ENDIF
73415  
73416 C...Vertex information trivial.
73417       DO 470 J=1,5
73418         V(INEW,J)=V(I,J)
73419         V(IGNEW,J)=V(I,J)
73420         V(IRNEW,J)=V(IR,J)
73421   470 CONTINUE
73422  
73423 C...Update list of old radiators.
73424       DO 480 IEVOL=1,NEVOL
73425 C...  A) radiator-recoiler mother pair for this branching
73426         IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
73427           IPOS(IEVOL)=INEW
73428 C...  A2) QCD branching and color side matches, radiated parton follows recoiler
73429           IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
73430           IREC(IEVOL)=IRNEW
73431           IFLG(IEVOL)=0
73432         ELSEIF(IPOS(IEVOL).EQ.I) THEN
73433 C...  B) other dipoles with I as radiator simply get INEW as new radiator
73434           IPOS(IEVOL)=INEW
73435           IFLG(IEVOL)=0
73436         ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
73437 C...  C) the "mirror image" of the parent dipole
73438           IPOS(IEVOL)=IRNEW
73439           IREC(IEVOL)=INEW
73440 C...  C2) QCD branching and color side matches, radiated parton follows recoiler
73441           IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0)
73442      &         IREC(IEVOL)=IGNEW
73443           IFLG(IEVOL)=0
73444         ELSEIF(IPOS(IEVOL).EQ.IR) THEN
73445 C...  D) other dipoles with IR as radiator simply get IRNEW as new radiator
73446           IPOS(IEVOL)=IRNEW
73447           IFLG(IEVOL)=0
73448         ENDIF
73449 C...  Update links of old connected partons.
73450         IF(IREC(IEVOL).EQ.I) THEN
73451           IREC(IEVOL)=INEW
73452           IFLG(IEVOL)=0
73453         ELSEIF(IREC(IEVOL).EQ.IR) THEN
73454           IREC(IEVOL)=IRNEW
73455           IFLG(IEVOL)=0
73456         ENDIF
73457   480 CONTINUE
73458  
73459 C...q->qg or g->gg: create new gluon radiators.
73460       IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
73461         NEVOL=NEVOL+1
73462         IPOS(NEVOL)=INEW
73463         IREC(NEVOL)=IGNEW
73464         IFLG(NEVOL)=0
73465         ISCOL(NEVOL)=KCOL
73466         ISCHG(NEVOL)=0
73467         PTSCA(NEVOL)=SQRT(PT2)
73468         IRIF(NEVOL)=0
73469         NEVOL=NEVOL+1
73470         IPOS(NEVOL)=IGNEW
73471         IREC(NEVOL)=INEW
73472         IFLG(NEVOL)=0
73473         ISCOL(NEVOL)=-KCOL
73474         ISCHG(NEVOL)=0
73475         PTSCA(NEVOL)=PTSCA(NEVOL-1)
73476         IRIF(NEVOL)=0
73477 C...g->qqbar: create new photon radiators.
73478       ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN
73479         NEVOL=NEVOL+1
73480         IPOS(NEVOL)=INEW
73481         IREC(NEVOL)=IGNEW
73482         IFLG(NEVOL)=0
73483         ISCOL(NEVOL)=0
73484         ISCHG(NEVOL)=PYK(INEW,6)
73485         PTSCA(NEVOL)=SQRT(PT2)
73486         IRIF(NEVOL)=0
73487         NEVOL=NEVOL+1
73488         IPOS(NEVOL)=IGNEW
73489         IREC(NEVOL)=INEW
73490         IFLG(NEVOL)=0
73491         ISCOL(NEVOL)=0
73492         ISCHG(NEVOL)=PYK(IGNEW,6)
73493         PTSCA(NEVOL)=SQRT(PT2)
73494         IRIF(NEVOL)=0
73495       ENDIF
73496  
73497 C...Check color and charge connections,
73498 C...Rewire if better partners can be found (screening, etc)
73499       DO 500 IEVOL=1,NEVOL
73500         KCOL  = ISCOL(IEVOL)
73501         KCHA  = ISCHG(IEVOL)
73502         IRTMP = IREC(IEVOL)
73503         ITMP  = IPOS(IEVOL)
73504 C...Do not modify QED dipoles
73505         IF (KCHA.NE.0) THEN
73506           GOTO 500
73507 C...Also skip dipole ends that are switched off
73508         ELSEIF (IFLG(IEVOL).LE.-1) THEN
73509           GOTO 500
73510         ELSEIF (KCOL.NE.0) THEN
73511 C...QCD dipoles. Check if current recoiler has appropriate color charge
73512           KCOLR = PYK(IRTMP,12)
73513           IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500
73514 C...If not, look for closest recoiler with appropriate color charge
73515           RM2MIN = PSUM(5)**2
73516           JMX    = 0
73517           ISGOOD = 0
73518           DO 490 JEVOL=1,NEVOL
73519 C...Skip self
73520             IF (JEVOL.EQ.IEVOL) GOTO 490
73521             JTMP = IPOS(JEVOL)
73522             IF (JTMP.EQ.ITMP) GOTO 490
73523             JCOL = ISCOL(JEVOL)
73524 C...Skip dipole ends that are switched off
73525             IF (IFLG(JEVOL).LE.-1) GOTO 490
73526 C...Skip QED dipole ends
73527             IF (ISCHG(JEVOL).NE.0) GOTO 490
73528 C...  Skip wrong-color if at least one correct-color partner already found
73529             IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490
73530 C...Accept if smallest m2 so far, or if first with correct color
73531             RM2 = DOTP(ITMP,JTMP)
73532             ISGNOW = 0
73533             IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1
73534             IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN
73535               ISGOOD = ISGNOW
73536               RM2MIN = RM2
73537               JMX    = JEVOL
73538             ENDIF
73539   490     CONTINUE
73540 C...Update recoiler and reset dipole if new best partner found
73541           IF (JMX.NE.0) THEN
73542             IREC(IEVOL) = IPOS(JMX)             
73543             IFLG(IEVOL) = 0
73544           ENDIF
73545         ENDIF
73546   500 CONTINUE
73547  
73548 C...TMP! print out list of dipoles
73549 C      DO 580 IEVOL=1,NEVOL
73550 C        KCHA  = ISCHG(IEVOL)
73551 C        IF (KCHA.NE.0) THEN
73552 C          print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
73553 C        ELSE
73554 C          print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
73555 C        ENDIF
73556 C 580  CONTINUE
73557  
73558 C...Update matrix elements parton list and add new for g/gamma->qqbar.
73559       DO 510 IME=1,NMESYS
73560         IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
73561         IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
73562         IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
73563         IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
73564   510 CONTINUE
73565       IF(KFQ.NE.0) THEN
73566         NMESYS=NMESYS+1
73567         MESYS(NMESYS,0)=66
73568         MESYS(NMESYS,1)=INEW
73569         MESYS(NMESYS,2)=IGNEW
73570         NMESYS=NMESYS+1
73571         MESYS(NMESYS,0)=102
73572         MESYS(NMESYS,1)=INEW
73573         MESYS(NMESYS,2)=IGNEW
73574       ENDIF
73575  
73576 C...Global statistics.
73577       MINT(353)=MINT(353)+1
73578       VINT(353)=VINT(353)+PTCOR
73579       IF (MINT(353).EQ.1) VINT(358)=PTCOR
73580  
73581 C...Loopback for more emissions if enough space.
73582       PT2CMX=PT2
73583       IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
73584      &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
73585         GOTO 300
73586       ELSE
73587         CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
73588       ENDIF
73589  
73590 C...Done.
73591   520 CONTINUE
73592  
73593       RETURN
73594       END
73595  
73596 C*********************************************************************
73597  
73598 C...PYMAEL
73599 C...Auxiliary to PYSHOW and PYPTFS.
73600 C...Matrix elements for gluon (or photon) emission from
73601 C...a two-body state; to be used by the parton shower routine.
73602 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
73603 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
73604 C...      = (alpha-strong/2 pi) * CF * PYMAEL,
73605 C...i.e. normalization is such that one recovers the familiar
73606 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
73607 C...Coupling structure:
73608 C...NI =  6- 9 : eikonal soft-gluon expression (spin-independent)
73609 C...   = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
73610 C...   = 16-19 : q -> q V
73611 C...   = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
73612 C...   = 26-29 : q -> q S
73613 C...   = 31-34 : V -> ~q ~qbar  (~q = squark)
73614 C...   = 36-39 : ~q -> ~q V
73615 C...   = 41-44 : S -> ~q ~qbar
73616 C...   = 46-49 : ~q -> ~q S
73617 C...   = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
73618 C...   = 56-59 : ~q -> q chi
73619 C...   = 61-64 : q -> ~q chi
73620 C...   = 66-69 : ~g -> q ~qbar
73621 C...   = 71-74 : ~q -> q ~g
73622 C...   = 76-79 : q -> ~q ~g
73623 C...   = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
73624 C...Note that the order of the decay products is important.
73625 C...In each set of four, the variants are ordered as:
73626 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
73627 C...       = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
73628 C...       = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
73629 C...       = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
73630  
73631       FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
73632  
73633 C...Double precision and integer declarations.
73634       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73635       IMPLICIT INTEGER(I-N)
73636  
73637 C...Check input values. Return zero outside allowed phase space.
73638       PYMAEL=0D0
73639       IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
73640       IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
73641       IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
73642       IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
73643      &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
73644       ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
73645  
73646 C...Initial values and flags.
73647       ICLASS=NI/5
73648       ICOMBI=NI-5*ICLASS
73649       ISSET1=0
73650       ISSET2=0
73651       ISSET4=0
73652  
73653 C... Phase space.
73654       PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
73655  
73656 C...Eikonal expression; also acts as default.
73657       IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
73658         RLO=PS
73659         IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
73660           ANUM=0D0
73661         ELSEIF(ICOMBI.EQ.2) THEN
73662           ANUM=(2D0-X1-X2)**2
73663         ELSEIF(ICOMBI.EQ.3) THEN
73664           ANUM=ALPCOR*(2D0-X1-X2)**2
73665         ELSE
73666           ANUM=0.5D0*(2D0-X1-X2)**2
73667         ENDIF
73668         RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
73669      &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
73670      &       R1**2/(1D0+R2**2-R1**2-X2)**2-
73671      &       R2**2/(1D0+R1**2-R2**2-X1)**2)
73672         ICOMBI=0
73673  
73674 C...V -> q qbar (V = gamma*/Z0/W+-/...).
73675       ELSEIF(ICLASS.EQ.2) THEN
73676         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73677         RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
73678         RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
73679      &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
73680      &       +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
73681      &       +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
73682      &       -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
73683      &       -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
73684      &       +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
73685      &       (-1+R1**2-R2**2+X2)**2
73686         RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
73687      &       +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
73688      &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
73689      &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
73690      &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
73691      &       -X1-X2)**2+X1*(2-X1-X2)**2)/
73692      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73693         RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
73694      &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
73695      &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
73696      &       -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
73697      &       (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
73698         RFO1=RFO1/2.D0
73699         ISSET1=1
73700         ENDIF
73701         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73702         RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
73703         RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
73704      &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
73705      &       +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
73706      &       -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
73707      &       +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
73708      &       -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
73709      &       +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
73710         RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
73711      &       -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
73712      &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
73713      &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
73714      &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
73715      &       -X1-X2)**2+X1*(2-X1-X2)**2)/
73716      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73717         RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
73718      &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
73719      &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
73720      &       -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
73721      &       +X2)/(-1-R1**2+R2**2+X1)**2
73722         RFO2=RFO2/2.D0
73723         ISSET2=1
73724         ENDIF
73725         IF(ICOMBI.EQ.4) THEN
73726         RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
73727         RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
73728      &       -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
73729      &       +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
73730      &       (-1-R1**2+R2**2+X1)**2
73731         RFO4=RFO4
73732      &       -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
73733      &       -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
73734      &       -R1**2*X2**2+X1*X2**2)/
73735      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73736         RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
73737      &       -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
73738      &       +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
73739      &       (-1+R1**2-R2**2+X2)**2
73740         RFO4=RFO4/2.D0
73741         ISSET4=1
73742         ENDIF
73743  
73744 C...q -> q V.
73745       ELSEIF(ICLASS.EQ.3) THEN
73746         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73747         RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
73748      &        +R1**2*R2**2-2D0*R2**4)
73749         RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
73750      &       -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
73751      &       +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
73752      &       +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
73753      &       +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
73754      &       -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
73755      &       -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
73756         RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
73757      &       +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
73758      &       -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
73759      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
73760      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
73761         RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
73762      &       +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
73763      &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
73764      &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
73765      &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73766      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
73767      &       +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
73768         ISSET1=1
73769         ENDIF
73770         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73771         RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
73772      &        +R1**2*R2**2-2D0*R2**4)
73773         RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
73774      &       +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
73775      &       -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
73776      &       -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
73777      &       -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
73778      &       +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
73779      &       -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73780         RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
73781      &       +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
73782      &       -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
73783      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
73784      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
73785         RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
73786      &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
73787      &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
73788      &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
73789      &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73790      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
73791      &       +X1*X2**2)/(-2+X1+X2)**2
73792         ISSET2=1
73793         ENDIF
73794         IF(ICOMBI.EQ.4) THEN
73795         RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
73796         RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
73797      &       -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
73798      &       -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
73799      &       +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
73800      &       +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73801         RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
73802      &       -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
73803      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
73804      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
73805         RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
73806      &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
73807      &       -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
73808      &       -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73809      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
73810      &       +X1*X2**2)/(2-X1-X2)**2
73811         ISSET4=1
73812         ENDIF
73813  
73814 C...S -> q qbar    (S = h0/H0/A0/H+-/...).
73815       ELSEIF(ICLASS.EQ.4) THEN
73816         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73817         RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
73818         RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73819      &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73820      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73821      &       -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
73822      &       +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
73823      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73824      &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73825      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73826      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73827         ISSET1=1
73828         ENDIF
73829         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73830         RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
73831         RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73832      &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73833      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73834      &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73835      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73836      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73837      &       +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
73838      &       -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
73839      &       -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73840      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73841         ISSET2=1
73842         ENDIF
73843         IF(ICOMBI.EQ.4) THEN
73844         RLO4=PS*(1D0-R1**2-R2**2)
73845         RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73846      &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73847      &       -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73848      &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73849      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73850      &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
73851      &       +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73852         ISSET4=1
73853         ENDIF
73854  
73855 C...q -> q S.
73856       ELSEIF(ICLASS.EQ.5) THEN
73857         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73858         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73859         RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73860      &       -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73861      &       +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
73862      &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73863      &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
73864      &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73865      &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73866      &       (-1+R1**2-R2**2+X2)**2
73867         ISSET1=1
73868         ENDIF
73869         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73870         RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73871         RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73872      &       +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73873      &       +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
73874      &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73875      &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
73876      &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73877      &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73878      &       (-1+R1**2-R2**2+X2)**2
73879         ISSET2=1
73880         ENDIF
73881         IF(ICOMBI.EQ.4) THEN
73882         RLO4=PS*(1D0+R1**2-R2**2)
73883         RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
73884      &       -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73885      &       +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
73886      &       -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
73887      &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73888      &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73889         ISSET4=1
73890         ENDIF
73891  
73892 C...V -> ~q ~qbar  (~q = squark).
73893       ELSEIF(ICLASS.EQ.6) THEN
73894         RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73895         RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
73896      &       (-1-R1**2+R2**2+X1)**2
73897      &       -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
73898      &       (-1-R1**2+R2**2+X1)
73899      &       +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
73900      &       /(-1+R1**2-R2**2+X2)**2
73901      &       -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
73902      &       (-1+R1**2-R2**2+X2)
73903      &       -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
73904      &       +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
73905      &       -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
73906      &       +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73907         ISSET1=1
73908  
73909 C...~q -> ~q V.
73910       ELSEIF(ICLASS.EQ.7) THEN
73911         RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73912         RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
73913      &       -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
73914      &       (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
73915      &       (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73916      &       +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
73917      &       -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
73918      &       (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
73919      &       (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
73920      &       +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
73921      &       +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
73922      &       (3*(-2+X1+X2))
73923         RFO1=3D0*RFO1/8D0
73924         ISSET1=1
73925  
73926 C...S -> ~q ~qbar.
73927       ELSEIF(ICLASS.EQ.8) THEN
73928         RLO1=PS
73929         RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73930      &       +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
73931      &       +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
73932      &       -R1**2*X2**2+X1*X2**2)/
73933      &       (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
73934         RFO1=2D0*RFO1
73935         ISSET1=1
73936  
73937 C...~q -> ~q S.
73938       ELSEIF(ICLASS.EQ.9) THEN
73939         RLO1=PS
73940         RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73941      &       +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73942      &       -(X1+X2)/(-2+X1+X2)**2
73943         ISSET1=1
73944  
73945 C...chi -> q ~qbar   (chi = neutralino/chargino).
73946       ELSEIF(ICLASS.EQ.10) THEN
73947         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73948         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73949         RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73950      &       +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
73951      &       -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73952      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73953      &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73954      &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73955      &       (-1+R1**2-R2**2+X2)**2
73956         ISSET1=1
73957         ENDIF
73958         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73959         RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
73960         RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
73961      &       +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
73962      &       -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
73963      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73964      &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73965      &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73966      &       (-1+R1**2-R2**2+X2)**2
73967         ISSET2=1
73968         ENDIF
73969         IF(ICOMBI.EQ.4) THEN
73970         RLO4=PS*(1+R1**2-R2**2)
73971         RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73972      &       +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
73973      &       +X2+R1**2*X2-X1*X2/2)/
73974      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73975      &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73976      &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73977         ISSET4=1
73978         ENDIF
73979  
73980 C...~q -> q chi.
73981       ELSEIF(ICLASS.EQ.11) THEN
73982         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73983         RLO1=PS*(1D0-(R1+R2)**2)
73984         RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73985      &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73986      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73987      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73988      &       +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73989      &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73990      &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73991         ISSET1=1
73992         ENDIF
73993         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73994         RLO2=PS*(1D0-(R1-R2)**2)
73995         RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
73996      &       (-2+X1+X2)**2
73997      &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73998      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73999      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
74000      &       +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
74001      &       +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
74002      &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
74003         ISSET2=1
74004         ENDIF
74005         IF(ICOMBI.EQ.4) THEN
74006         RLO4=PS*(1D0-R1**2-R2**2)
74007         RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
74008      &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
74009      &       +3*R1**2*X2-R2**2*X2-X1*X2)/
74010      &       (-1+R1**2-R2**2+X2)**2
74011      &       -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
74012      &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
74013      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
74014         ISSET4=1
74015         ENDIF
74016  
74017 C...q -> ~q chi.
74018       ELSEIF(ICLASS.EQ.12) THEN
74019         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
74020         RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
74021         RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
74022      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
74023      &       -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
74024      &       (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
74025      &       +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
74026      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
74027         ISSET1=1
74028         END IF
74029         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
74030         RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
74031         RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
74032      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
74033      &       -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
74034      &       (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
74035      &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
74036      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
74037         ISSET2=1
74038         END IF
74039         IF(ICOMBI.EQ.4) THEN
74040         RLO4=PS*(1D0-R1**2+R2**2)
74041         RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
74042      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
74043      &       -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
74044      &       (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
74045      &       +R1**2*X2-X1*X2/2-X2**2/2)/
74046      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
74047         ISSET4=1
74048         END IF
74049  
74050 C...~g -> q ~qbar.
74051       ELSEIF(ICLASS.EQ.13) THEN
74052         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
74053         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
74054         RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
74055      &       -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
74056      &       -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
74057      &       +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
74058      &       +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
74059      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
74060      &       -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
74061      &       +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
74062      &       +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
74063      &       +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
74064      &       -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
74065      &       -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74066      &       (3*(-1+R1**2-R2**2+X2)**2)
74067         RFO1=3D0*RFO1/4D0
74068         ISSET1=1
74069         ENDIF
74070         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
74071         RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
74072         RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
74073      &       -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
74074      &       +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
74075      &       +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
74076      &       +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
74077      &       (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
74078      &       +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
74079      &       +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
74080      &       -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
74081      &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74082      &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
74083      &       +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
74084      &       +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74085      &       (3*(-1+R1**2-R2**2+X2)**2)
74086         RFO2=3D0*RFO2/4D0
74087         ISSET2=1
74088         ENDIF
74089         IF(ICOMBI.EQ.4) THEN
74090         RLO4=PS*(1D0+R1**2-R2**2)
74091         RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
74092      &       -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
74093      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
74094      &       +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
74095      &       +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
74096      &       +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74097      &       (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
74098      &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74099      &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
74100      &       +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
74101      &       (3*(-1+R1**2-R2**2+X2)**2)
74102         RFO4=3D0*RFO4/8D0
74103         ISSET4=1
74104         ENDIF
74105  
74106 C...~q -> q ~g.
74107       ELSEIF(ICLASS.EQ.14) THEN
74108         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
74109         RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
74110         RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
74111      &       -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
74112      &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
74113      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
74114      &       -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
74115      &       -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
74116      &       -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
74117      &       -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
74118      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
74119      &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
74120      &       +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
74121      &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
74122      &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
74123         RFO1=RFO1
74124      &       +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
74125      &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
74126      &       +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
74127         RFO1=9D0*RFO1/64D0
74128         ISSET1=1
74129         ENDIF
74130         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
74131         RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
74132         RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
74133      &       -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
74134      &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
74135      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
74136      &       +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
74137      &       -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
74138      &       -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
74139      &       -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
74140      &       +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
74141      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
74142         RFO2=RFO2
74143      &       +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
74144      &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
74145      &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
74146      &       +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
74147      &       +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
74148      &       -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
74149         RFO2=9D0*RFO2/64D0
74150         ISSET2=1
74151         ENDIF
74152         IF(ICOMBI.EQ.4) THEN
74153         RLO4=PS*(1-R1**2-R2**2)
74154         RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
74155      &       +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
74156      &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
74157      &       -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
74158      &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
74159      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
74160      &       -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
74161      &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
74162      &       +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
74163      &       +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
74164      &       ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
74165         RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
74166      &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
74167      &       (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
74168         RFO4=9D0*RFO4/128D0
74169         ISSET4=1
74170         ENDIF
74171  
74172 C...q -> ~q ~g.
74173       ELSEIF(ICLASS.EQ.15) THEN
74174         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
74175         RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
74176         RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
74177      &       +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
74178      &       +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
74179      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
74180      &       -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
74181      &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
74182      &       (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
74183      &       -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
74184      &       +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
74185         RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
74186      &       +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
74187      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
74188      &       -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
74189      &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
74190         RFO1=9D0*RFO1/32D0
74191         ISSET1=1
74192         END IF
74193         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
74194         RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
74195         RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
74196      &       +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
74197      &       +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
74198      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
74199      &       +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
74200      &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
74201      &       (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
74202      &       +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
74203      &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
74204         RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
74205      &       +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
74206      &       (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
74207      &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
74208      &       (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
74209         RFO2=9D0*RFO2/32D0
74210         ISSET2=1
74211         END IF
74212         IF(ICOMBI.EQ.4) THEN
74213         RLO4=PS*(1D0-R1**2+R2**2)
74214         RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
74215      &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
74216      &       -R2**2*X2/2-X1*X2/2)/
74217      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
74218      &       -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
74219      &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
74220      &       +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
74221      &       -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
74222         RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
74223      &       -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
74224      &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
74225      &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
74226         RFO4=9D0*RFO4/64D0
74227         ISSET4=1
74228         END IF
74229  
74230 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
74231       ELSEIF(ICLASS.EQ.16) THEN
74232         RLO=PS
74233         IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
74234           ANUM=0D0
74235         ELSEIF(ICOMBI.EQ.2) THEN
74236           ANUM=(2D0-X1-X2)**2
74237         ELSEIF(ICOMBI.EQ.3) THEN
74238           ANUM=ALPCOR*(2D0-X1-X2)**2
74239         ELSE
74240           ANUM=0.5D0*(2D0-X1-X2)**2
74241         ENDIF
74242         RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
74243      &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
74244      &       R1**2/(1D0+R2**2-R1**2-X2)**2-
74245      &       R2**2/(1D0+R1**2-R2**2-X1)**2)
74246         RFO=9D0*RFO/4D0
74247         ICOMBI=0
74248       ENDIF
74249  
74250 C...Find relevant LO and FO expression.
74251       IF(ICOMBI.EQ.0) THEN
74252       ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
74253         RLO=RLO1
74254         RFO=RFO1
74255       ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
74256         RLO=RLO2
74257         RFO=RFO2
74258       ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
74259         RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
74260         RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
74261       ELSEIF(ISSET4.EQ.1) THEN
74262         RLO=RLO4
74263         RFO=RFO4
74264       ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
74265         RLO=0.5D0*(RLO1+RLO2)
74266         RFO=0.5D0*(RFO1+RFO2)
74267       ELSEIF(ISSET1.EQ.1) THEN
74268         RLO=RLO1
74269         RFO=RFO1
74270       ELSE
74271         CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
74272         RLO=1D0
74273         RFO=0D0
74274       ENDIF
74275  
74276 C...Output.
74277       PYMAEL=RFO/RLO
74278  
74279       RETURN
74280       END
74281  
74282 C*********************************************************************
74283  
74284 C...PYBOEI
74285 C...Modifies an event so as to approximately take into account
74286 C...Bose-Einstein effects according to a simple phenomenological
74287 C...parametrization.
74288  
74289       SUBROUTINE PYBOEI(NSAV)
74290  
74291 C...Double precision and integer declarations.
74292       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74293       IMPLICIT INTEGER(I-N)
74294       INTEGER PYK,PYCHGE,PYCOMP
74295 C...Parameter statement to help give large particle numbers.
74296       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74297      &KEXCIT=4000000,KDIMEN=5000000)
74298 C...Commonblocks.
74299       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74300       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74301       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74302       COMMON/PYINT1/MINT(400),VINT(400)
74303       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
74304 C...Local arrays and data.
74305       DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
74306      &BEIW(100),BEI3W(100)
74307       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
74308 C...Statement function: squared invariant mass.
74309       SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
74310      &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
74311  
74312 C...Boost event to overall CM frame. Calculate CM energy.
74313       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
74314       DO 100 J=1,4
74315         DPS(J)=0D0
74316   100 CONTINUE
74317       DO 120 I=1,N
74318         KFA=IABS(K(I,2))
74319         IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
74320      &  .AND.K(I,3).GT.0) THEN
74321           KFMA=IABS(K(K(I,3),2))
74322           IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
74323         ENDIF
74324         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
74325         DO 110 J=1,4
74326           DPS(J)=DPS(J)+P(I,J)
74327   110   CONTINUE
74328   120 CONTINUE
74329       CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
74330      &-DPS(3)/DPS(4))
74331       PECM=0D0
74332       DO 130 I=1,N
74333         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
74334   130 CONTINUE
74335  
74336 C...Check if we have separated strings
74337  
74338 C...Reserve copy of particles by species at end of record.
74339       IWP=0
74340       IWN=0
74341       NBE(0)=N+MSTU(3)
74342       NMAX=NBE(0)
74343       SMMIN=PECM
74344       DO 190 IBE=1,MIN(10,MSTJ(52)+1)
74345         NBE(IBE)=NBE(IBE-1)
74346         DO 180 I=NSAV+1,N
74347           IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
74348             DO 140 IIBE=1,IBE-1
74349               IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
74350   140       CONTINUE
74351           ELSE
74352             IF(K(I,2).NE.KFBE(IBE)) GOTO 180
74353           ENDIF
74354           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
74355           IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
74356             CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
74357             RETURN
74358           ENDIF
74359           NBE(IBE)=NBE(IBE)+1
74360           NMAX=NBE(IBE)
74361           K(NBE(IBE),1)=I
74362           K(NBE(IBE),2)=0
74363           K(NBE(IBE),3)=0
74364           K(NBE(IBE),4)=0
74365           K(NBE(IBE),5)=0
74366           P(NBE(IBE),1)=0.0D0
74367           P(NBE(IBE),2)=0.0D0
74368           P(NBE(IBE),3)=0.0D0
74369           P(NBE(IBE),4)=0.0D0
74370           P(NBE(IBE),5)=0.0D0
74371           SMMIN=MIN(SMMIN,P(I,5))
74372 C...Check if particles comes from different W's or Z's
74373           IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
74374             IM=I
74375   150       IF(K(IM,3).GT.0) THEN
74376               IM=K(IM,3)
74377               IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
74378               K(NBE(IBE),5)=IM
74379               IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
74380               IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
74381               IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
74382               IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
74383             ENDIF
74384           ENDIF
74385 C...Check if particles comes from different strings.
74386           IF(PARJ(94).GT.0.0D0) THEN
74387             IM=I
74388   160       IF(K(IM,3).GT.0) THEN
74389               IM=K(IM,3)
74390               IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
74391               K(NBE(IBE),5)=IM
74392             ENDIF
74393           ENDIF
74394           DO 170 J=1,3
74395             P(NBE(IBE),J)=0D0
74396             V(NBE(IBE),J)=0D0
74397   170     CONTINUE
74398           P(NBE(IBE),5)=-1.0D0
74399   180   CONTINUE
74400   190 CONTINUE
74401       IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
74402  
74403 C...Calculate separation between W+ and W- or between two Z0's.
74404 C...No separation if there has been re-connections.
74405       SIGW=PARJ(93)
74406       IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
74407         IF(K(IWP,2).EQ.23) THEN
74408           DMW=PMAS(23,1)
74409           DGW=PMAS(23,2)
74410         ELSE
74411           DMW=PMAS(24,1)
74412           DGW=PMAS(24,2)
74413         ENDIF
74414         DMP=P(IWP,5)
74415         DMN=P(IWN,5)
74416         TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
74417         TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
74418         TAUP=-TAUPD*LOG(PYR(IDUM))
74419         TAUN=-TAUND*LOG(PYR(IDUM))
74420         DXP=TAUP*PYP(IWP,8)/DMP
74421         DXN=TAUN*PYP(IWN,8)/DMN
74422         DX=DXP+DXN
74423         SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
74424         IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
74425       ENDIF
74426  
74427 C...Add separation between strings.
74428       IF(PARJ(94).GT.0.0D0) THEN
74429         SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
74430         IWP=-1
74431         IWN=-1
74432       ENDIF
74433  
74434       IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
74435         DO 220 IBE=1,MIN(9,MSTJ(52))
74436           DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
74437             Q2MIN=PECM**2
74438             I1=K(I1M,1)
74439             DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
74440               IF(I2M.EQ.I1M) GOTO 200
74441               I2=K(I2M,1)
74442               Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
74443      &        (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
74444      &        (P(I1,5)+P(I2,5))**2
74445               IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
74446                 Q2MIN=Q2
74447               ENDIF
74448   200       CONTINUE
74449             P(I1M,5)=Q2MIN
74450   210     CONTINUE
74451   220   CONTINUE
74452       ENDIF
74453  
74454 C...Tabulate integral for subsequent momentum shift.
74455       DO 400 IBE=1,MIN(9,MSTJ(52))
74456         IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
74457         IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
74458      &  .LE.1) GOTO 270
74459         IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
74460      &  NBE(7)-NBE(6)).LE.1) GOTO 270
74461         IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
74462         IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
74463         IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
74464         IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
74465         IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
74466         QDEL=0.1D0*MIN(PMHQ,PARJ(93))
74467         QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
74468         QDELW=0.1D0*MIN(PMHQ,SIGW)
74469         QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
74470         IF(MSTJ(51).EQ.1) THEN
74471           NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
74472           NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
74473           NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
74474           NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
74475           BEEX=EXP(0.5D0*QDEL/PARJ(93))
74476           BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
74477           BEEXW=EXP(0.5D0*QDELW/SIGW)
74478           BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
74479           BERT=EXP(-QDEL/PARJ(93))
74480           BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
74481           BERTW=EXP(-QDELW/SIGW)
74482           BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
74483         ELSE
74484           NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
74485           NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
74486           NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
74487           NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
74488         ENDIF
74489         DO 230 IBIN=1,NBIN
74490           QBIN=QDEL*(IBIN-0.5D0)
74491           BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
74492           IF(MSTJ(51).EQ.1) THEN
74493             BEEX=BEEX*BERT
74494             BEI(IBIN)=BEI(IBIN)*BEEX
74495           ELSE
74496             BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
74497           ENDIF
74498           IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
74499   230   CONTINUE
74500         DO 240 IBIN=1,NBIN3
74501           QBIN=QDEL3*(IBIN-0.5D0)
74502           BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
74503           IF(MSTJ(51).EQ.1) THEN
74504             BEEX3=BEEX3*BERT3
74505             BEI3(IBIN)=BEI3(IBIN)*BEEX3
74506           ELSE
74507             BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
74508           ENDIF
74509           IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
74510   240   CONTINUE
74511         DO 250 IBIN=1,NBINW
74512           QBIN=QDELW*(IBIN-0.5D0)
74513           BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
74514           IF(MSTJ(51).EQ.1) THEN
74515             BEEXW=BEEXW*BERTW
74516             BEIW(IBIN)=BEIW(IBIN)*BEEXW
74517           ELSE
74518             BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
74519           ENDIF
74520           IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
74521   250   CONTINUE
74522         DO 260 IBIN=1,NBIN3W
74523           QBIN=QDEL3W*(IBIN-0.5D0)
74524           BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
74525      &    SQRT(QBIN**2+PMHQ**2)
74526           IF(MSTJ(51).EQ.1) THEN
74527             BEEX3W=BEEX3W*BERT3W
74528             BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
74529           ELSE
74530             BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
74531           ENDIF
74532           IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
74533   260   CONTINUE
74534  
74535 C...Loop through particle pairs and find old relative momentum.
74536   270   DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
74537           I1=K(I1M,1)
74538           DO 380 I2M=I1M+1,NBE(IBE)
74539             IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
74540             IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
74541             I2=K(I2M,1)
74542             Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
74543      &      P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
74544             IF(Q2OLD.LE.0.0D0) GOTO 380
74545             QOLD=SQRT(Q2OLD)
74546  
74547 C...Calculate new relative momentum.
74548             QMOV=0.0D0
74549             QMOV3=0.0D0
74550             QMOVW=0.0D0
74551             QMOV3W=0.0D0
74552             IF(QOLD.LT.1D-3*QDEL) THEN
74553               GOTO 280
74554             ELSEIF(QOLD.LE.QDEL) THEN
74555               QMOV=QOLD/3D0
74556             ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
74557               RBIN=QOLD/QDEL
74558               IBIN=RBIN
74559               RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
74560               QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
74561      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
74562             ELSE
74563               QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
74564             ENDIF
74565   280       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
74566             IF(QOLD.LT.1D-3*QDEL3) THEN
74567               GOTO 290
74568             ELSEIF(QOLD.LE.QDEL3) THEN
74569               QMOV3=QOLD/3D0
74570             ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
74571               RBIN3=QOLD/QDEL3
74572               IBIN3=RBIN3
74573               RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
74574               QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
74575      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
74576             ELSE
74577               QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
74578             ENDIF
74579   290       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
74580             RSCALE=1.0D0
74581             IF(MSTJ(54).EQ.2)
74582      &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
74583             IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
74584      &      K(I1M,5).EQ.K(I2M,5)) GOTO 320
74585  
74586             IF(QOLD.LT.1D-3*QDELW) THEN
74587               GOTO 300
74588             ELSEIF(QOLD.LE.QDELW) THEN
74589               QMOVW=QOLD/3D0
74590             ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
74591               RBINW=QOLD/QDELW
74592               IBINW=RBINW
74593               RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
74594               QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
74595      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
74596             ELSE
74597               QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
74598             ENDIF
74599   300       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
74600             IF(QOLD.LT.1D-3*QDEL3W) THEN
74601               GOTO 310
74602             ELSEIF(QOLD.LE.QDEL3W) THEN
74603               QMOV3W=QOLD/3D0
74604             ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
74605               RBIN3W=QOLD/QDEL3W
74606               IBIN3W=RBIN3W
74607               RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
74608               QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
74609      &        BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
74610             ELSE
74611               QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
74612             ENDIF
74613   310       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
74614             IF(MSTJ(54).EQ.2)
74615      &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
74616  
74617   320       CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
74618             DO 330 J=1,3
74619               P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
74620               P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
74621   330       CONTINUE
74622             IF(MSTJ(54).GE.1) THEN
74623               CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
74624               DO 340 J=1,3
74625                 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
74626                 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
74627   340         CONTINUE
74628             ELSEIF(MSTJ(54).LE.-1) THEN
74629               EDEL=P(I1,4)+P(I2,4)-
74630      &        SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
74631               A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
74632      &        (P(I1,3)-P(I2,3))**2
74633               WMAX=-1.0D20
74634               MI3=0
74635               MI4=0
74636               S12=SDIP(I1,I2)
74637               SM1=(P(I1,5)+SMMIN)**2
74638               DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
74639                 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
74640                 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
74641                 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
74642      &          K(I3M,5).NE.K(I1M,5)) GOTO 360
74643                 I3=K(I3M,1)
74644                 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
74645                 S13=SDIP(I1,I3)
74646                 S23=SDIP(I2,I3)
74647                 SM3=(P(I3,5)+SMMIN)**2
74648                 IF(MSTJ(54).EQ.-2) THEN
74649                   WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
74650      &            S23*MIN(SM1,SM3))*SM1)
74651                 ELSE
74652                   WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
74653      &            (P(I1,3)+P(I2,3)+P(I3,3))**2-
74654      &            (P(I1,2)+P(I2,2)+P(I3,2))**2-
74655      &            (P(I1,1)+P(I2,1)+P(I3,1))**2)
74656                 ENDIF
74657                 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
74658                   IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
74659      &                 GOTO 360
74660                 ELSE
74661                   IF(WMAX*WI.GE.1.0) GOTO 360
74662                 ENDIF
74663                 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
74664                   IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
74665                   IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
74666                   IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
74667      &            K(I4M,5).NE.K(I1M,5)) GOTO 350
74668                   I4=K(I4M,1)
74669                   IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
74670      &            GOTO 350
74671                   IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
74672      &            (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
74673      &            (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
74674      &            GOTO 350
74675                   IF(MSTJ(54).EQ.-2) THEN
74676                     S14=SDIP(I1,I4)
74677                     S24=SDIP(I2,I4)
74678                     S34=SDIP(I3,I4)
74679                     W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
74680                     W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
74681                     W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
74682                     W=MIN(W,MIN(S23,S24)*S13*S14)
74683                     W=1.0D0/W
74684                   ELSE
74685 C...weight=1-cos(theta)/mtot2
74686                     S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
74687      &              (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
74688      &              (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
74689      &              (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
74690                     W=1.0D0/S1234
74691                     IF(W.LE.WMAX) GOTO 350
74692                   ENDIF
74693                   IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
74694      &            W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
74695                   IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
74696      &            W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
74697                   IF(W.LE.WMAX) GOTO 350
74698                   MI3=I3M
74699                   MI4=I4M
74700                   WMAX=W
74701   350           CONTINUE
74702   360         CONTINUE
74703               IF(MI4.EQ.0) GOTO 380
74704               I3=K(MI3,1)
74705               I4=K(MI4,1)
74706               EOLD=P(I3,4)+P(I4,4)
74707               ENEW=EOLD+EDEL
74708               P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
74709      &        (P(I3,3)+P(I4,3))**2
74710               Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
74711               Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
74712               CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
74713               DO 370 J=1,3
74714                 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
74715                 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
74716   370         CONTINUE
74717             ENDIF
74718   380     CONTINUE
74719   390   CONTINUE
74720   400 CONTINUE
74721  
74722 C...Shift momenta and recalculate energies.
74723       ESUMP=0.0D0
74724       ESUM=0.0D0
74725       PROD=0.0D0
74726       DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
74727         I=K(IM,1)
74728         ESUMP=ESUMP+P(I,4)
74729         DO 410 J=1,3
74730           P(I,J)=P(I,J)+P(IM,J)
74731   410   CONTINUE
74732         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74733         ESUM=ESUM+P(I,4)
74734         DO 420 J=1,3
74735           PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
74736   420   CONTINUE
74737   430 CONTINUE
74738  
74739       PARJ(96)=0.0D0
74740       IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
74741   440   ALPHA=(ESUMP-ESUM)/PROD
74742         PARJ(96)=PARJ(96)+ALPHA
74743         PROD=0.0D0
74744         ESUM=0.0D0
74745         DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
74746           I=K(IM,1)
74747           DO 450 J=1,3
74748             P(I,J)=P(I,J)+ALPHA*V(IM,J)
74749   450     CONTINUE
74750           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74751           ESUM=ESUM+P(I,4)
74752           DO 460 J=1,3
74753             PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
74754   460     CONTINUE
74755   470   CONTINUE
74756         IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
74757      &  GOTO 440
74758       ENDIF
74759  
74760 C...Rescale all momenta for energy conservation.
74761       PES=0D0
74762       PQS=0D0
74763       DO 480 I=1,N
74764         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
74765         PES=PES+P(I,4)
74766         PQS=PQS+P(I,5)**2/P(I,4)
74767   480 CONTINUE
74768       PARJ(95)=PES-PECM
74769       FAC=(PECM-PQS)/(PES-PQS)
74770       DO 500 I=1,N
74771         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
74772         DO 490 J=1,3
74773           P(I,J)=FAC*P(I,J)
74774   490   CONTINUE
74775         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74776   500 CONTINUE
74777  
74778 C...Boost back to correct reference frame.
74779   510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
74780       DO 520 I=1,N
74781         IF(K(I,1).LT.0) K(I,1)=-K(I,1)
74782   520 CONTINUE
74783  
74784       RETURN
74785       END
74786  
74787 C*********************************************************************
74788  
74789 C...PYBESQ
74790 C...Calculates the momentum shift in a system of two particles assuming
74791 C...the relative momentum squared should be shifted to Q2NEW. NI is the
74792 C...last position occupied in /PYJETS/.
74793  
74794       SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
74795  
74796 C...Double precision and integer declarations.
74797       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74798       IMPLICIT INTEGER(I-N)
74799       INTEGER PYK,PYCHGE,PYCOMP
74800 C...Parameter statement to help give large particle numbers.
74801       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74802      &KEXCIT=4000000,KDIMEN=5000000)
74803 C...Commonblocks.
74804       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74805       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74806       SAVE /PYJETS/,/PYDAT1/
74807 C...Local arrays and data.
74808       DIMENSION DP(5)
74809       SAVE HC1
74810  
74811       IF(MSTJ(55).EQ.0) THEN
74812         DQ2=Q2NEW-Q2OLD
74813         DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
74814      &  (P(I1,3)-P(I2,3))**2
74815         DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
74816      &  -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
74817         SE=P(I1,4)+P(I2,4)
74818         DE=P(I1,4)-P(I2,4)
74819         DQ2SE=DQ2+SE**2
74820         DA=SE*DE*DP12-DP2*DQ2SE
74821         DB=DP2*DQ2SE-DP12**2
74822         HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
74823         DO 100 J=1,3
74824           PD=HA*(P(I1,J)-P(I2,J))
74825           P(NI+1,J)=PD
74826           P(NI+2,J)=-PD
74827   100   CONTINUE
74828         RETURN
74829       ENDIF
74830  
74831       K(NI+1,1)=1
74832       K(NI+2,1)=1
74833       DO 110 J=1,5
74834         P(NI+1,J)=P(I1,J)
74835         P(NI+2,J)=P(I2,J)
74836         DP(J)=P(I1,J)+P(I2,J)
74837   110 CONTINUE
74838  
74839 C...Boost to cms and rotate first particle to z-axis
74840       CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
74841      &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
74842       PHI=PYANGL(P(NI+1,1),P(NI+1,2))
74843       THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
74844       S=Q2NEW+(P(I1,5)+P(I2,5))**2
74845       PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
74846       P(NI+1,1)=0.0D0
74847       P(NI+1,2)=0.0D0
74848       P(NI+1,3)=PZ
74849       P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
74850       P(NI+2,1)=0.0D0
74851       P(NI+2,2)=0.0D0
74852       P(NI+2,3)=-PZ
74853       P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
74854       DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
74855       CALL PYROBO(NI+1,NI+2,THE,PHI,
74856      &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
74857  
74858       DO 120 J=1,3
74859         P(NI+1,J)=P(NI+1,J)-P(I1,J)
74860         P(NI+2,J)=P(NI+2,J)-P(I2,J)
74861   120 CONTINUE
74862  
74863       RETURN
74864       END
74865  
74866 C*********************************************************************
74867  
74868 C...PYMASS
74869 C...Gives the mass of a particle/parton.
74870  
74871       FUNCTION PYMASS(KF)
74872  
74873 C...Double precision and integer declarations.
74874       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74875       IMPLICIT INTEGER(I-N)
74876       INTEGER PYK,PYCHGE,PYCOMP
74877 C...Commonblocks.
74878       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74879       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74880       SAVE /PYDAT1/,/PYDAT2/
74881  
74882 C...Reset variables. Compressed code. Special case for popcorn diquarks.
74883       PYMASS=0D0
74884       KFA=IABS(KF)
74885       KC=PYCOMP(KF)
74886       IF(KC.EQ.0) THEN
74887         MSTJ(93)=0
74888         RETURN
74889       ENDIF
74890  
74891 C...Guarantee use of constituent masses for internal checks.
74892       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
74893      &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
74894         IF(KFA.LE.5) THEN
74895           PYMASS=PARF(100+KFA)
74896           IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
74897         ELSEIF(KFA.LE.10) THEN
74898           PYMASS=PMAS(KFA,1)
74899         ELSEIF(MSTJ(93).EQ.1) THEN
74900           PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
74901         ELSE
74902           PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
74903         ENDIF
74904  
74905 C...Other masses can be read directly off table.
74906       ELSE
74907         PYMASS=PMAS(KC,1)
74908       ENDIF
74909  
74910 C...Optional mass broadening according to truncated Breit-Wigner
74911 C...(either in m or in m^2).
74912       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
74913         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
74914           PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
74915      &    ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
74916         ELSE
74917           PM0=PYMASS
74918           PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
74919      &    (PM0*PMAS(KC,2)))
74920           PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
74921           PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
74922      &    (PMUPP-PMLOW)*PYR(0))))
74923         ENDIF
74924       ENDIF
74925       MSTJ(93)=0
74926  
74927       RETURN
74928       END
74929  
74930 C*********************************************************************
74931  
74932 C...PYMRUN
74933 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
74934 C...for Higgs couplings. Everything else sent on to PYMASS.
74935  
74936       FUNCTION PYMRUN(KF,Q2)
74937  
74938 C...Double precision and integer declarations.
74939       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74940       IMPLICIT INTEGER(I-N)
74941       INTEGER PYK,PYCHGE,PYCOMP
74942 C...Commonblocks.
74943       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74944       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74945       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74946       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
74947  
74948 C...Most masses not handled here.
74949       KFA=IABS(KF)
74950       IF(KFA.EQ.0.OR.KFA.GT.6) THEN
74951         PYMRUN=PYMASS(KF)
74952  
74953 C...Current-algebra masses, but no Q2 dependence.
74954       ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
74955         PYMRUN=PARF(90+KFA)
74956  
74957 C...Running current-algebra masses.
74958       ELSE
74959         AS=PYALPS(Q2)
74960         PYMRUN=PARF(90+KFA)*
74961      &  (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
74962      &  LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
74963       ENDIF
74964  
74965       RETURN
74966       END
74967  
74968 C*********************************************************************
74969  
74970 C...PYNAME
74971 C...Gives the particle/parton name as a character string.
74972  
74973       SUBROUTINE PYNAME(KF,CHAU)
74974  
74975 C...Double precision and integer declarations.
74976       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74977       IMPLICIT INTEGER(I-N)
74978       INTEGER PYK,PYCHGE,PYCOMP
74979 C...Commonblocks.
74980       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74981       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74982       COMMON/PYDAT4/CHAF(500,2)
74983       CHARACTER CHAF*16
74984       SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
74985 C...Local character variable.
74986       CHARACTER CHAU*16
74987  
74988 C...Read out code with distinction particle/antiparticle.
74989       CHAU=' '
74990       KC=PYCOMP(KF)
74991       IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
74992  
74993  
74994       RETURN
74995       END
74996  
74997 C*********************************************************************
74998  
74999 C...PYCHGE
75000 C...Gives three times the charge for a particle/parton.
75001  
75002       FUNCTION PYCHGE(KF)
75003  
75004 C...Double precision and integer declarations.
75005       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75006       IMPLICIT INTEGER(I-N)
75007       INTEGER PYK,PYCHGE,PYCOMP
75008 C...Commonblocks.
75009       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75010       SAVE /PYDAT2/
75011  
75012 C...Read out charge and change sign for antiparticle.
75013       PYCHGE=0
75014       KC=PYCOMP(KF)
75015       IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
75016  
75017       RETURN
75018       END
75019  
75020 C*********************************************************************
75021  
75022 C...PYCOMP
75023 C...Compress the standard KF codes for use in mass and decay arrays;
75024 C...also checks whether a given code actually is defined.
75025  
75026       FUNCTION PYCOMP(KF)
75027  
75028 C...Double precision and integer declarations.
75029       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75030       IMPLICIT INTEGER(I-N)
75031       INTEGER PYK,PYCHGE,PYCOMP
75032 C...Commonblocks.
75033       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75034       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75035       SAVE /PYDAT1/,/PYDAT2/
75036 C...Local arrays and saved data.
75037       DIMENSION KFORD(100:500),KCORD(101:500)
75038       SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
75039  
75040 C...Whenever necessary reorder codes for faster search.
75041       IF(MSTU(20).EQ.0) THEN
75042         NFORD=100
75043         KFORD(100)=0
75044         DO 120 I=101,500
75045           KFA=KCHG(I,4)
75046           IF(KFA.LE.100) GOTO 120
75047           NFORD=NFORD+1
75048           DO 100 I1=NFORD-1,0,-1
75049             IF(KFA.GE.KFORD(I1)) GOTO 110
75050             KFORD(I1+1)=KFORD(I1)
75051             KCORD(I1+1)=KCORD(I1)
75052   100     CONTINUE
75053   110     KFORD(I1+1)=KFA
75054           KCORD(I1+1)=I
75055   120   CONTINUE
75056         MSTU(20)=1
75057         KFLAST=0
75058         KCLAST=0
75059       ENDIF
75060  
75061 C...Fast action if same code as in latest call.
75062       IF(KF.EQ.KFLAST) THEN
75063         PYCOMP=KCLAST
75064         RETURN
75065       ENDIF
75066  
75067 C...Starting values. Remove internal diquark flags.
75068       PYCOMP=0
75069       KFA=IABS(KF)
75070       IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
75071      &     .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
75072  
75073 C...Simple cases: direct translation.
75074       IF(KFA.GT.KFORD(NFORD)) THEN
75075       ELSEIF(KFA.LE.100) THEN
75076         PYCOMP=KFA
75077  
75078 C...Else binary search.
75079       ELSE
75080         IMIN=100
75081         IMAX=NFORD+1
75082   130   IAVG=(IMIN+IMAX)/2
75083         IF(KFORD(IAVG).GT.KFA) THEN
75084           IMAX=IAVG
75085           IF(IMAX.GT.IMIN+1) GOTO 130
75086         ELSEIF(KFORD(IAVG).LT.KFA) THEN
75087           IMIN=IAVG
75088           IF(IMAX.GT.IMIN+1) GOTO 130
75089         ELSE
75090           PYCOMP=KCORD(IAVG)
75091         ENDIF
75092       ENDIF
75093  
75094 C...Check if antiparticle allowed.
75095       IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
75096         IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
75097       ENDIF
75098  
75099 C...Save codes for possible future fast action.
75100       KFLAST=KF
75101       KCLAST=PYCOMP
75102  
75103       RETURN
75104       END
75105  
75106 C*********************************************************************
75107  
75108 C...PYERRM
75109 C...Informs user of errors in program execution.
75110  
75111       SUBROUTINE PYERRM(MERR,CHMESS)
75112  
75113 C...Double precision and integer declarations.
75114       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75115       IMPLICIT INTEGER(I-N)
75116       INTEGER PYK,PYCHGE,PYCOMP
75117 C...Commonblocks.
75118       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75119       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75120       SAVE /PYJETS/,/PYDAT1/
75121 C...Local character variable.
75122       CHARACTER CHMESS*(*)
75123  
75124 C...Write first few warnings, then be silent.
75125       IF(MERR.LE.10) THEN
75126         MSTU(27)=MSTU(27)+1
75127         MSTU(28)=MERR
75128         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
75129      &  MERR,MSTU(31),CHMESS
75130  
75131 C...Write first few errors, then be silent or stop program.
75132       ELSEIF(MERR.LE.20) THEN
75133         IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
75134         MSTU(30)=MSTU(30)+1
75135         MSTU(24)=MERR-10
75136         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
75137      &  MERR-10,MSTU(31),CHMESS
75138         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
75139           WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
75140           WRITE(MSTU(11),5200)
75141           IF(MERR.NE.17) CALL PYLIST(2)
75142           CALL PYSTOP(3)
75143         ENDIF
75144  
75145 C...Stop program in case of irreparable error.
75146       ELSE
75147         WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
75148         CALL PYSTOP(3)
75149       ENDIF
75150  
75151 C...Formats for output.
75152  5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
75153      &' PYEXEC calls:'/5X,A)
75154  5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
75155      &' PYEXEC calls:'/5X,A)
75156  5200 FORMAT(5X,'Execution will be stopped after listing of last ',
75157      &'event!')
75158  5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
75159      &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
75160  
75161       RETURN
75162       END
75163  
75164 C*********************************************************************
75165  
75166 C...PYALEM
75167 C...Calculates the running alpha_electromagnetic.
75168  
75169       FUNCTION PYALEM(Q2)
75170  
75171 C...Double precision and integer declarations.
75172       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75173       IMPLICIT INTEGER(I-N)
75174       INTEGER PYK,PYCHGE,PYCOMP
75175 C...Commonblocks.
75176       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75177       SAVE /PYDAT1/
75178  
75179 C...Calculate real part of photon vacuum polarization.
75180 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
75181 C...For hadrons use parametrization of H. Burkhardt et al.
75182 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
75183       AEMPI=PARU(101)/(3D0*PARU(1))
75184       IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
75185         RPIGG=0D0
75186       ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
75187         RPIGG=0D0
75188       ELSEIF(MSTU(101).EQ.2) THEN
75189         RPIGG=1D0-PARU(101)/PARU(103)
75190       ELSEIF(Q2.LT.0.09D0) THEN
75191         RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
75192       ELSEIF(Q2.LT.9D0) THEN
75193         RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
75194      &  0.00238D0*LOG(1D0+3.927D0*Q2)
75195       ELSEIF(Q2.LT.1D4) THEN
75196         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
75197      &  0.00299D0*LOG(1D0+Q2)
75198       ELSE
75199         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
75200      &  0.00293D0*LOG(1D0+Q2)
75201       ENDIF
75202  
75203 C...Calculate running alpha_em.
75204       PYALEM=PARU(101)/(1D0-RPIGG)
75205       PARU(108)=PYALEM
75206  
75207       RETURN
75208       END
75209  
75210 C*********************************************************************
75211  
75212 C...PYALPS
75213 C...Gives the value of alpha_strong.
75214  
75215       FUNCTION PYALPS(Q2)
75216  
75217 C...Double precision and integer declarations.
75218       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75219       IMPLICIT INTEGER(I-N)
75220       INTEGER PYK,PYCHGE,PYCOMP
75221 C...Commonblocks.
75222       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75223       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75224       SAVE /PYDAT1/,/PYDAT2/
75225 C...Coefficients for second-order threshold matching.
75226 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
75227       DIMENSION STEPDN(6),STEPUP(6)
75228 c      DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
75229 c     &(2D0*321D0/3703D0),0D0/
75230 c      DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
75231 c     &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
75232       DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
75233       DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
75234  
75235 C...Constant alpha_strong trivial. Pick artificial Lambda.
75236       IF(MSTU(111).LE.0) THEN
75237         PYALPS=PARU(111)
75238         MSTU(118)=MSTU(112)
75239         PARU(117)=0.2D0
75240         IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
75241      &  ((33D0-2D0*MSTU(112))*PARU(111)))
75242         PARU(118)=PARU(111)
75243         RETURN
75244       ENDIF
75245  
75246 C...Find effective Q2, number of flavours and Lambda.
75247       Q2EFF=Q2
75248       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
75249       NF=MSTU(112)
75250       ALAM2=PARU(112)**2
75251   100 IF(NF.GT.MAX(3,MSTU(113))) THEN
75252         Q2THR=PARU(113)*PMAS(NF,1)**2
75253         IF(Q2EFF.LT.Q2THR) THEN
75254           NF=NF-1
75255           Q2RAT=Q2THR/ALAM2
75256           ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
75257           IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
75258           GOTO 100
75259         ENDIF
75260       ENDIF
75261   110 IF(NF.LT.MIN(6,MSTU(114))) THEN
75262         Q2THR=PARU(113)*PMAS(NF+1,1)**2
75263         IF(Q2EFF.GT.Q2THR) THEN
75264           NF=NF+1
75265           Q2RAT=Q2THR/ALAM2
75266           ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
75267           IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
75268           GOTO 110
75269         ENDIF
75270       ENDIF
75271       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
75272       PARU(117)=SQRT(ALAM2)
75273  
75274 C...Evaluate first or second order alpha_strong.
75275       B0=(33D0-2D0*NF)/6D0
75276       ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
75277       IF(MSTU(111).EQ.1) THEN
75278         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
75279       ELSE
75280         B1=(153D0-19D0*NF)/6D0
75281         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
75282      &  (B0**2*ALGQ)))
75283       ENDIF
75284       MSTU(118)=NF
75285       PARU(118)=PYALPS
75286  
75287       RETURN
75288       END
75289  
75290 C*********************************************************************
75291  
75292 C...PYANGL
75293 C...Reconstructs an angle from given x and y coordinates.
75294  
75295       FUNCTION PYANGL(X,Y)
75296  
75297 C...Double precision and integer declarations.
75298       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75299       IMPLICIT INTEGER(I-N)
75300       INTEGER PYK,PYCHGE,PYCOMP
75301 C...Commonblocks.
75302       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75303       SAVE /PYDAT1/
75304  
75305       PYANGL=0D0
75306       R=SQRT(X**2+Y**2)
75307       IF(R.LT.1D-20) RETURN
75308       IF(ABS(X)/R.LT.0.8D0) THEN
75309         PYANGL=SIGN(ACOS(X/R),Y)
75310       ELSE
75311         PYANGL=ASIN(Y/R)
75312         IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
75313           PYANGL=PARU(1)-PYANGL
75314         ELSEIF(X.LT.0D0) THEN
75315           PYANGL=-PARU(1)-PYANGL
75316         ENDIF
75317       ENDIF
75318  
75319       RETURN
75320       END
75321  
75322 C*********************************************************************
75323  
75324 C...PYR
75325 C...Generates random numbers uniformly distributed between
75326 C...0 and 1, excluding the endpoints.
75327  
75328       FUNCTION PYR(IDUMMY)
75329  
75330 C...Double precision and integer declarations.
75331       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75332       IMPLICIT INTEGER(I-N)
75333       INTEGER PYK,PYCHGE,PYCOMP
75334 C...Commonblocks.
75335       COMMON/PYDATR/MRPY(6),RRPY(100)
75336       SAVE /PYDATR/
75337 C...Equivalence between commonblock and local variables.
75338       EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
75339      &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
75340      &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
75341  
75342 C...Initialize generation from given seed.
75343       IF(MRPY2.EQ.0) THEN
75344         IJ=MOD(MRPY1/30082,31329)
75345         KL=MOD(MRPY1,30082)
75346         I=MOD(IJ/177,177)+2
75347         J=MOD(IJ,177)+2
75348         K=MOD(KL/169,178)+1
75349         L=MOD(KL,169)
75350         DO 110 II=1,97
75351           S=0D0
75352           T=0.5D0
75353           DO 100 JJ=1,48
75354             M=MOD(MOD(I*J,179)*K,179)
75355             I=J
75356             J=K
75357             K=M
75358             L=MOD(53*L+1,169)
75359             IF(MOD(L*M,64).GE.32) S=S+T
75360             T=0.5D0*T
75361   100     CONTINUE
75362           RRPY(II)=S
75363   110   CONTINUE
75364         TWOM24=1D0
75365         DO 120 I24=1,24
75366           TWOM24=0.5D0*TWOM24
75367   120   CONTINUE
75368         RRPY98=362436D0*TWOM24
75369         RRPY99=7654321D0*TWOM24
75370         RRPY00=16777213D0*TWOM24
75371         MRPY2=1
75372         MRPY3=0
75373         MRPY4=97
75374         MRPY5=33
75375       ENDIF
75376  
75377 C...Generate next random number.
75378   130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
75379       IF(RUNI.LT.0D0) RUNI=RUNI+1D0
75380       RRPY(MRPY4)=RUNI
75381       MRPY4=MRPY4-1
75382       IF(MRPY4.EQ.0) MRPY4=97
75383       MRPY5=MRPY5-1
75384       IF(MRPY5.EQ.0) MRPY5=97
75385       RRPY98=RRPY98-RRPY99
75386       IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
75387       RUNI=RUNI-RRPY98
75388       IF(RUNI.LT.0D0) RUNI=RUNI+1D0
75389       IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
75390  
75391 C...Update counters. Random number to output.
75392       MRPY3=MRPY3+1
75393       IF(MRPY3.EQ.1000000000) THEN
75394         MRPY2=MRPY2+1
75395         MRPY3=0
75396       ENDIF
75397       PYR=RUNI
75398  
75399       RETURN
75400       END
75401  
75402 C*********************************************************************
75403  
75404 C...PYRGET
75405 C...Dumps the state of the random number generator on a file
75406 C...for subsequent startup from this state onwards.
75407  
75408       SUBROUTINE PYRGET(LFN,MOVE)
75409  
75410 C...Double precision and integer declarations.
75411       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75412       IMPLICIT INTEGER(I-N)
75413       INTEGER PYK,PYCHGE,PYCOMP
75414 C...Commonblocks.
75415       COMMON/PYDATR/MRPY(6),RRPY(100)
75416       SAVE /PYDATR/
75417 C...Local character variable.
75418       CHARACTER CHERR*8
75419  
75420 C...Backspace required number of records (or as many as there are).
75421       IF(MOVE.LT.0) THEN
75422         NBCK=MIN(MRPY(6),-MOVE)
75423         DO 100 IBCK=1,NBCK
75424           BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
75425   100   CONTINUE
75426         MRPY(6)=MRPY(6)-NBCK
75427       ENDIF
75428  
75429 C...Unformatted write on unit LFN.
75430       WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
75431      &(RRPY(I2),I2=1,100)
75432       MRPY(6)=MRPY(6)+1
75433       RETURN
75434  
75435 C...Write error.
75436   110 WRITE(CHERR,'(I8)') IERR
75437       CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
75438      &CHERR)
75439  
75440       RETURN
75441       END
75442  
75443 C*********************************************************************
75444  
75445 C...PYRSET
75446 C...Reads a state of the random number generator from a file
75447 C...for subsequent generation from this state onwards.
75448  
75449       SUBROUTINE PYRSET(LFN,MOVE)
75450  
75451 C...Double precision and integer declarations.
75452       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75453       IMPLICIT INTEGER(I-N)
75454       INTEGER PYK,PYCHGE,PYCOMP
75455 C...Commonblocks.
75456       COMMON/PYDATR/MRPY(6),RRPY(100)
75457       SAVE /PYDATR/
75458 C...Local character variable.
75459       CHARACTER CHERR*8
75460  
75461 C...Backspace required number of records (or as many as there are).
75462       IF(MOVE.LT.0) THEN
75463         NBCK=MIN(MRPY(6),-MOVE)
75464         DO 100 IBCK=1,NBCK
75465           BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
75466   100   CONTINUE
75467         MRPY(6)=MRPY(6)-NBCK
75468       ENDIF
75469  
75470 C...Unformatted read from unit LFN.
75471       NFOR=1+MAX(0,MOVE)
75472       DO 110 IFOR=1,NFOR
75473         READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
75474      &  (RRPY(I2),I2=1,100)
75475   110 CONTINUE
75476       MRPY(6)=MRPY(6)+NFOR
75477       RETURN
75478  
75479 C...Write error.
75480   120 WRITE(CHERR,'(I8)') IERR
75481       CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
75482      &CHERR)
75483  
75484       RETURN
75485       END
75486  
75487 C*********************************************************************
75488  
75489 C...PYROBO
75490 C...Performs rotations and boosts.
75491  
75492       SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
75493  
75494 C...Double precision and integer declarations.
75495       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75496       IMPLICIT INTEGER(I-N)
75497       INTEGER PYK,PYCHGE,PYCOMP
75498 C...Commonblocks.
75499       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75500       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75501       SAVE /PYJETS/,/PYDAT1/
75502 C...Local arrays.
75503       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
75504  
75505 C...Find and check range of rotation/boost.
75506       IMIN=IMI
75507       IF(IMIN.LE.0) IMIN=1
75508       IF(MSTU(1).GT.0) IMIN=MSTU(1)
75509       IMAX=IMA
75510       IF(IMAX.LE.0) IMAX=N
75511       IF(MSTU(2).GT.0) IMAX=MSTU(2)
75512       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
75513         CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
75514         RETURN
75515       ENDIF
75516  
75517 C...Optional resetting of V (when not set before.)
75518       IF(MSTU(33).NE.0) THEN
75519         DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
75520           DO 100 J=1,5
75521             V(I,J)=0D0
75522   100     CONTINUE
75523   110   CONTINUE
75524         MSTU(33)=0
75525       ENDIF
75526  
75527 C...Rotate, typically from z axis to direction (theta,phi).
75528       IF(THE**2+PHI**2.GT.1D-20) THEN
75529         ROT(1,1)=COS(THE)*COS(PHI)
75530         ROT(1,2)=-SIN(PHI)
75531         ROT(1,3)=SIN(THE)*COS(PHI)
75532         ROT(2,1)=COS(THE)*SIN(PHI)
75533         ROT(2,2)=COS(PHI)
75534         ROT(2,3)=SIN(THE)*SIN(PHI)
75535         ROT(3,1)=-SIN(THE)
75536         ROT(3,2)=0D0
75537         ROT(3,3)=COS(THE)
75538         DO 140 I=IMIN,IMAX
75539           IF(K(I,1).LE.0) GOTO 140
75540           DO 120 J=1,3
75541             PR(J)=P(I,J)
75542             VR(J)=V(I,J)
75543   120     CONTINUE
75544           DO 130 J=1,3
75545             P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
75546             V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
75547   130     CONTINUE
75548   140   CONTINUE
75549       ENDIF
75550  
75551 C...Boost, typically from rest to momentum/energy=beta.
75552       IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
75553         DBX=BEX
75554         DBY=BEY
75555         DBZ=BEZ
75556         DB=SQRT(DBX**2+DBY**2+DBZ**2)
75557         EPS1=1D0-1D-12
75558         IF(DB.GT.EPS1) THEN
75559 C...Rescale boost vector if too close to unity.
75560           CALL PYERRM(3,'(PYROBO:) boost vector too large')
75561           DBX=DBX*(EPS1/DB)
75562           DBY=DBY*(EPS1/DB)
75563           DBZ=DBZ*(EPS1/DB)
75564           DB=EPS1
75565         ENDIF
75566         DGA=1D0/SQRT(1D0-DB**2)
75567         DO 160 I=IMIN,IMAX
75568           IF(K(I,1).LE.0) GOTO 160
75569           DO 150 J=1,4
75570             DP(J)=P(I,J)
75571             DV(J)=V(I,J)
75572   150     CONTINUE
75573           DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
75574           DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
75575           P(I,1)=DP(1)+DGABP*DBX
75576           P(I,2)=DP(2)+DGABP*DBY
75577           P(I,3)=DP(3)+DGABP*DBZ
75578           P(I,4)=DGA*(DP(4)+DBP)
75579           DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
75580           DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
75581           V(I,1)=DV(1)+DGABV*DBX
75582           V(I,2)=DV(2)+DGABV*DBY
75583           V(I,3)=DV(3)+DGABV*DBZ
75584           V(I,4)=DGA*(DV(4)+DBV)
75585   160   CONTINUE
75586       ENDIF
75587  
75588       RETURN
75589       END
75590  
75591 C*********************************************************************
75592  
75593 C...PYEDIT
75594 C...Performs global manipulations on the event record, in particular
75595 C...to exclude unstable or undetectable partons/particles.
75596  
75597       SUBROUTINE PYEDIT(MEDIT)
75598  
75599 C...Double precision and integer declarations.
75600       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75601       IMPLICIT INTEGER(I-N)
75602       INTEGER PYK,PYCHGE,PYCOMP
75603 C...Parameter statement to help give large particle numbers.
75604       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75605      &KEXCIT=4000000,KDIMEN=5000000)
75606 C...Commonblocks.
75607       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75608       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75609       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75610       COMMON/PYCTAG/NCT,MCT(4000,2)
75611       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
75612 C...Local arrays.
75613       DIMENSION NS(2),PTS(2),PLS(2)
75614  
75615 C...Remove unwanted partons/particles.
75616       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
75617         IMAX=N
75618         IF(MSTU(2).GT.0) IMAX=MSTU(2)
75619         I1=MAX(1,MSTU(1))-1
75620         DO 110 I=MAX(1,MSTU(1)),IMAX
75621           IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
75622           IF(MEDIT.EQ.1) THEN
75623             IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
75624           ELSEIF(MEDIT.EQ.2) THEN
75625             IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
75626             KC=PYCOMP(K(I,2))
75627             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75628      &      KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75629      &      K(I,2).EQ.KSUSY1+39) GOTO 110
75630           ELSEIF(MEDIT.EQ.3) THEN
75631             IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
75632             KC=PYCOMP(K(I,2))
75633             IF(KC.EQ.0) GOTO 110
75634             IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
75635           ELSEIF(MEDIT.EQ.5) THEN
75636             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
75637             KC=PYCOMP(K(I,2))
75638             IF(KC.EQ.0) GOTO 110
75639             IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
75640      &      KCHG(KC,2).EQ.0) GOTO 110
75641           ENDIF
75642  
75643 C...Pack remaining partons/particles. Origin no longer known.
75644           I1=I1+1
75645           DO 100 J=1,5
75646             K(I1,J)=K(I,J)
75647             P(I1,J)=P(I,J)
75648             V(I1,J)=V(I,J)
75649   100     CONTINUE
75650           K(I1,3)=0
75651   110   CONTINUE
75652         IF(I1.LT.N) MSTU(3)=0
75653         IF(I1.LT.N) MSTU(70)=0
75654         N=I1
75655  
75656 C...Selective removal of class of entries. New position of retained.
75657       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
75658         I1=0
75659         DO 120 I=1,N
75660           K(I,3)=MOD(K(I,3),MSTU(5))
75661           IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
75662           IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
75663           IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
75664      &    K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
75665           IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
75666      &    K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
75667           IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
75668           I1=I1+1
75669           K(I,3)=K(I,3)+MSTU(5)*I1
75670   120   CONTINUE
75671  
75672 C...Find new event history information and replace old.
75673         DO 140 I=1,N
75674           IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
75675      &    K(I,3)/MSTU(5).EQ.0) GOTO 140
75676           ID=I
75677   130     IM=MOD(K(ID,3),MSTU(5))
75678           IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
75679             IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
75680      &      K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
75681               ID=IM
75682               GOTO 130
75683             ENDIF
75684           ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
75685             IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
75686      &      K(IM,2).EQ.94) THEN
75687               ID=IM
75688               GOTO 130
75689             ENDIF
75690           ENDIF
75691           K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
75692           IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
75693           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
75694      &      K(I,1).NE.42.AND.K(I,1).NE.52) THEN
75695             IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
75696      &      K(K(I,4),3)/MSTU(5)
75697             IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
75698      &      K(K(I,5),3)/MSTU(5)
75699           ELSE
75700             KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
75701             IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
75702      &      K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
75703             KCD=MOD(K(I,4),MSTU(5))
75704             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
75705             K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
75706             KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
75707             IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
75708             KCD=MOD(K(I,5),MSTU(5))
75709             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
75710             K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
75711           ENDIF
75712   140   CONTINUE
75713  
75714 C...Pack remaining entries.
75715         I1=0
75716         MSTU90=MSTU(90)
75717         MSTU(90)=0
75718         DO 170 I=1,N
75719           IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
75720           I1=I1+1
75721           DO 150 J=1,5
75722             K(I1,J)=K(I,J)
75723             P(I1,J)=P(I,J)
75724             V(I1,J)=V(I,J)
75725   150     CONTINUE
75726 C...Also update LHA1 colour tags
75727           MCT(I1,1)=MCT(I,1)
75728           MCT(I1,2)=MCT(I,2)
75729           K(I1,3)=MOD(K(I1,3),MSTU(5))
75730           DO 160 IZ=1,MSTU90
75731             IF(I.EQ.MSTU(90+IZ)) THEN
75732               MSTU(90)=MSTU(90)+1
75733               MSTU(90+MSTU(90))=I1
75734               PARU(90+MSTU(90))=PARU(90+IZ)
75735             ENDIF
75736   160     CONTINUE
75737   170   CONTINUE
75738         IF(I1.LT.N) MSTU(3)=0
75739         IF(I1.LT.N) MSTU(70)=0
75740         N=I1
75741  
75742 C...Fill in some missing daughter pointers (lost in colour flow).
75743       ELSEIF(MEDIT.EQ.16) THEN
75744         DO 220 I=1,N
75745           IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
75746           IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
75747 C...Find daughters who point to mother.
75748           DO 180 I1=I+1,N
75749             IF(K(I1,3).NE.I) THEN
75750             ELSEIF(K(I,4).EQ.0) THEN
75751               K(I,4)=I1
75752             ELSE
75753               K(I,5)=I1
75754             ENDIF
75755   180     CONTINUE
75756           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
75757           IF(K(I,4).NE.0) GOTO 220
75758 C...Find daughters who point to documentation version of mother.
75759           IM=K(I,3)
75760           IF(IM.LE.0.OR.IM.GE.I) GOTO 220
75761           IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
75762           IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
75763           DO 190 I1=I+1,N
75764             IF(K(I1,3).NE.IM) THEN
75765             ELSEIF(K(I,4).EQ.0) THEN
75766               K(I,4)=I1
75767             ELSE
75768               K(I,5)=I1
75769             ENDIF
75770   190     CONTINUE
75771           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
75772           IF(K(I,4).NE.0) GOTO 220
75773 C...Find daughters who point to documentation daughters who,
75774 C...in their turn, point to documentation mother.
75775           ID1=IM
75776           ID2=IM
75777           DO 200 I1=IM+1,I-1
75778             IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
75779               ID2=I1
75780               IF(ID1.EQ.IM) ID1=I1
75781             ENDIF
75782   200     CONTINUE
75783           DO 210 I1=I+1,N
75784             IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
75785             ELSEIF(K(I,4).EQ.0) THEN
75786               K(I,4)=I1
75787             ELSE
75788               K(I,5)=I1
75789             ENDIF
75790   210     CONTINUE
75791           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
75792   220   CONTINUE
75793  
75794 C...Save top entries at bottom of PYJETS commonblock.
75795       ELSEIF(MEDIT.EQ.21) THEN
75796         IF(2*N.GE.MSTU(4)) THEN
75797           CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
75798           RETURN
75799         ENDIF
75800         DO 240 I=1,N
75801           DO 230 J=1,5
75802             K(MSTU(4)-I,J)=K(I,J)
75803             P(MSTU(4)-I,J)=P(I,J)
75804             V(MSTU(4)-I,J)=V(I,J)
75805   230     CONTINUE
75806   240   CONTINUE
75807         MSTU(32)=N
75808  
75809 C...Restore bottom entries of commonblock PYJETS to top.
75810       ELSEIF(MEDIT.EQ.22) THEN
75811         DO 260 I=1,MSTU(32)
75812           DO 250 J=1,5
75813             K(I,J)=K(MSTU(4)-I,J)
75814             P(I,J)=P(MSTU(4)-I,J)
75815             V(I,J)=V(MSTU(4)-I,J)
75816   250     CONTINUE
75817   260   CONTINUE
75818         N=MSTU(32)
75819  
75820 C...Mark primary entries at top of commonblock PYJETS as untreated.
75821       ELSEIF(MEDIT.EQ.23) THEN
75822         I1=0
75823         DO 270 I=1,N
75824           KH=K(I,3)
75825           IF(KH.GE.1) THEN
75826             IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
75827           ENDIF
75828           IF(KH.NE.0) GOTO 280
75829           I1=I1+1
75830           IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
75831           IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
75832   270   CONTINUE
75833   280   N=I1
75834  
75835 C...Place largest axis along z axis and second largest in xy plane.
75836       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
75837         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
75838      &  P(MSTU(61),2)),0D0,0D0,0D0)
75839         CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
75840      &  P(MSTU(61),1)),0D0,0D0,0D0,0D0)
75841         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
75842      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
75843         IF(MEDIT.EQ.31) RETURN
75844  
75845 C...Rotate to put slim jet along +z axis.
75846         DO 290 IS=1,2
75847           NS(IS)=0
75848           PTS(IS)=0D0
75849           PLS(IS)=0D0
75850   290   CONTINUE
75851         DO 300 I=1,N
75852           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
75853           IF(MSTU(41).GE.2) THEN
75854             KC=PYCOMP(K(I,2))
75855             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75856      &      KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75857      &      K(I,2).EQ.KSUSY1+39) GOTO 300
75858             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
75859      &      .EQ.0) GOTO 300
75860           ENDIF
75861           IS=2D0-SIGN(0.5D0,P(I,3))
75862           NS(IS)=NS(IS)+1
75863           PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
75864   300   CONTINUE
75865         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
75866      &  CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
75867  
75868 C...Rotate to put second largest jet into -z,+x quadrant.
75869         DO 310 I=1,N
75870           IF(P(I,3).GE.0D0) GOTO 310
75871           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
75872           IF(MSTU(41).GE.2) THEN
75873             KC=PYCOMP(K(I,2))
75874             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75875      &      KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75876      &      K(I,2).EQ.KSUSY1+39) GOTO 310
75877             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
75878      &      .EQ.0) GOTO 310
75879           ENDIF
75880           IS=2D0-SIGN(0.5D0,P(I,1))
75881           PLS(IS)=PLS(IS)-P(I,3)
75882   310   CONTINUE
75883         IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
75884      &  0D0,0D0,0D0)
75885       ENDIF
75886  
75887       RETURN
75888       END
75889  
75890 C*********************************************************************
75891  
75892 C...PYLIST
75893 C...Gives program heading, or lists an event, or particle
75894 C...data, or current parameter values.
75895  
75896       SUBROUTINE PYLIST(MLIST)
75897  
75898 C...Double precision and integer declarations.
75899       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75900       IMPLICIT INTEGER(I-N)
75901       INTEGER PYK,PYCHGE,PYCOMP
75902 C...Parameter statement to help give large particle numbers.
75903       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75904      &KEXCIT=4000000,KDIMEN=5000000)
75905  
75906 C...HEPEVT commonblock.
75907       PARAMETER (NMXHEP=4000)
75908       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
75909      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
75910       DOUBLE PRECISION PHEP,VHEP
75911       SAVE /HEPEVT/
75912  
75913 C...User process event common block.
75914       INTEGER MAXNUP
75915       PARAMETER (MAXNUP=500)
75916       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75917       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75918       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75919      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75920      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75921       SAVE /HEPEUP/
75922  
75923 C...Commonblocks.
75924       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75925       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75926       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75927       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75928       COMMON/PYCTAG/NCT,MCT(4000,2)
75929       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
75930 C...Local arrays, character variables and data.
75931       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
75932       DIMENSION PS(6)
75933       DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
75934  
75935 C...Initialization printout: version number and date of last change.
75936       IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
75937         CALL PYLOGO
75938         MSTU(12)=12345
75939         IF(MLIST.EQ.0) RETURN
75940       ENDIF
75941  
75942 C...List event data, including additional lines after N.
75943       IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
75944         IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
75945         IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
75946         IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
75947         IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
75948         LMX=12
75949         IF(MLIST.GE.2) LMX=16
75950         ISTR=0
75951         IMAX=N
75952         IF(MSTU(2).GT.0) IMAX=MSTU(2)
75953         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
75954           IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
75955           IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
75956           IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
75957  
75958 C...Get particle name, pad it and check it is not too long.
75959           CALL PYNAME(K(I,2),CHAP)
75960           LEN=0
75961           DO 100 LEM=1,16
75962             IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
75963   100     CONTINUE
75964           MDL=(K(I,1)+19)/10
75965           LDL=0
75966           IF(MDL.EQ.2.OR.MDL.GE.8) THEN
75967             CHAC=CHAP
75968             IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
75969           ELSE
75970             LDL=1
75971             IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
75972             IF(LEN.EQ.0) THEN
75973               CHAC=CHDL(MDL)(1:2*LDL)//' '
75974             ELSE
75975               CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
75976      &        CHDL(MDL)(LDL+1:2*LDL)//' '
75977               IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
75978             ENDIF
75979           ENDIF
75980  
75981 C...Add information on string connection.
75982           IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
75983      &    THEN
75984             KC=PYCOMP(K(I,2))
75985             KCC=0
75986             IF(KC.NE.0) KCC=KCHG(KC,2)
75987             IF(IABS(K(I,2)).EQ.39) THEN
75988               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
75989             ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
75990               ISTR=1
75991               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
75992             ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
75993               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
75994             ELSEIF(KCC.NE.0) THEN
75995               ISTR=0
75996               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
75997             ENDIF
75998           ENDIF
75999           IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
76000      &    CHAC(LMX-1:LMX-1)='I'
76001  
76002 C...Write data for particle/jet.
76003           IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
76004             WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
76005      &      (P(I,J2),J2=1,5)
76006           ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
76007             WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
76008      &      (P(I,J2),J2=1,5)
76009           ELSEIF(MLIST.EQ.1) THEN
76010             WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
76011      &      (P(I,J2),J2=1,5)
76012           ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
76013      &      K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
76014             IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
76015      &      K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
76016      &      K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
76017      &      (P(I,J2),J2=1,5)
76018             IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
76019      &      K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
76020      &           K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
76021      &           ,10000),MCT(I,1),MCT(I,2)
76022           ELSE
76023             IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
76024      &      (P(I,J2),J2=1,5)
76025             IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
76026      &           ,MCT(I,1),MCT(I,2)
76027           ENDIF
76028           IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
76029  
76030 C...Insert extra separator lines specified by user.
76031           IF(MSTU(70).GE.1) THEN
76032             ISEP=0
76033             DO 110 J=1,MIN(10,MSTU(70))
76034               IF(I.EQ.MSTU(70+J)) ISEP=1
76035   110       CONTINUE
76036             IF(ISEP.EQ.1) THEN
76037               IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
76038               IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
76039               IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
76040             ENDIF
76041           ENDIF
76042   120   CONTINUE
76043  
76044 C...Sum of charges and momenta.
76045         DO 130 J=1,6
76046           PS(J)=PYP(0,J)
76047   130   CONTINUE
76048         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
76049           WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
76050         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
76051           WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
76052         ELSEIF(MLIST.EQ.1) THEN
76053           WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
76054         ELSEIF(MLIST.LE.3) THEN
76055           WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
76056         ELSE
76057           WRITE(MSTU(11),7000) PS(6)
76058         ENDIF
76059  
76060 C...Simple listing of HEPEVT entries (mainly for test purposes).
76061       ELSEIF(MLIST.EQ.5) THEN
76062         WRITE(MSTU(11),7100)
76063         DO 140 I=1,NHEP
76064           IF(ISTHEP(I).EQ.0) GOTO 140
76065           WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
76066      &    JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
76067   140   CONTINUE
76068  
76069  
76070 C...Simple listing of user-process entries (mainly for test purposes).
76071       ELSEIF(MLIST.EQ.7) THEN
76072         WRITE(MSTU(11),7300)
76073         DO 150 I=1,NUP
76074           WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
76075      &    MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
76076   150   CONTINUE
76077  
76078 C...Give simple list of KF codes defined in program.
76079       ELSEIF(MLIST.EQ.11) THEN
76080         WRITE(MSTU(11),7500)
76081         DO 160 KF=1,80
76082           CALL PYNAME(KF,CHAP)
76083           CALL PYNAME(-KF,CHAN)
76084           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
76085           IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
76086   160   CONTINUE
76087         DO 190 KFLS=1,3,2
76088           DO 180 KFLA=1,5
76089             DO 170 KFLB=1,KFLA-(3-KFLS)/2
76090               KF=1000*KFLA+100*KFLB+KFLS
76091               CALL PYNAME(KF,CHAP)
76092               CALL PYNAME(-KF,CHAN)
76093               WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
76094   170       CONTINUE
76095   180     CONTINUE
76096   190   CONTINUE
76097         DO 220 KMUL=0,5
76098           KFLS=3
76099           IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
76100           IF(KMUL.EQ.5) KFLS=5
76101           KFLR=0
76102           IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
76103           IF(KMUL.EQ.4) KFLR=2
76104           DO 210 KFLB=1,5
76105             DO 200 KFLC=1,KFLB-1
76106               KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
76107               CALL PYNAME(KF,CHAP)
76108               CALL PYNAME(-KF,CHAN)
76109               WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
76110               IF(KF.EQ.311) THEN
76111                 KFK=130
76112                 CALL PYNAME(KFK,CHAP)
76113                 WRITE(MSTU(11),7600) KFK,CHAP
76114                 KFK=310
76115                 CALL PYNAME(KFK,CHAP)
76116                 WRITE(MSTU(11),7600) KFK,CHAP
76117               ENDIF
76118   200       CONTINUE
76119             KF=10000*KFLR+110*KFLB+KFLS
76120             CALL PYNAME(KF,CHAP)
76121             WRITE(MSTU(11),7600) KF,CHAP
76122   210     CONTINUE
76123   220   CONTINUE
76124         KF=100443
76125         CALL PYNAME(KF,CHAP)
76126         WRITE(MSTU(11),7600) KF,CHAP
76127         KF=100553
76128         CALL PYNAME(KF,CHAP)
76129         WRITE(MSTU(11),7600) KF,CHAP
76130         DO 260 KFLSP=1,3
76131           KFLS=2+2*(KFLSP/3)
76132           DO 250 KFLA=1,5
76133             DO 240 KFLB=1,KFLA
76134               DO 230 KFLC=1,KFLB
76135                 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
76136      &          GOTO 230
76137                 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
76138                 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
76139                 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
76140                 CALL PYNAME(KF,CHAP)
76141                 CALL PYNAME(-KF,CHAN)
76142                 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
76143   230         CONTINUE
76144   240       CONTINUE
76145   250     CONTINUE
76146   260   CONTINUE
76147         DO 270 KC=1,500
76148           KF=KCHG(KC,4)
76149           IF(KF.LT.1000000) GOTO 270
76150           CALL PYNAME(KF,CHAP)
76151           CALL PYNAME(-KF,CHAN)
76152           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
76153           IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
76154   270   CONTINUE
76155  
76156 C...List parton/particle data table. Check whether to be listed.
76157       ELSEIF(MLIST.EQ.12) THEN
76158         WRITE(MSTU(11),7700)
76159         DO 300 KC=1,MSTU(6)
76160           KF=KCHG(KC,4)
76161           IF(KF.EQ.0) GOTO 300
76162           IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
76163      &    GOTO 300
76164  
76165 C...Find particle name and mass. Print information.
76166           CALL PYNAME(KF,CHAP)
76167           IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
76168           CALL PYNAME(-KF,CHAN)
76169           WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
76170      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
76171  
76172 C...Particle decay: channel number, branching ratios, matrix element,
76173 C...decay products.
76174           DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
76175             DO 280 J=1,5
76176               CALL PYNAME(KFDP(IDC,J),CHAD(J))
76177   280       CONTINUE
76178             WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
76179      &      (CHAD(J),J=1,5)
76180   290     CONTINUE
76181   300   CONTINUE
76182  
76183 C...List parameter value table.
76184       ELSEIF(MLIST.EQ.13) THEN
76185         WRITE(MSTU(11),8000)
76186         DO 310 I=1,200
76187           WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
76188   310   CONTINUE
76189       ENDIF
76190  
76191 C...Format statements for output on unit MSTU(11) (by default 6).
76192  5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
76193      &5X,'KF  orig    p_x      p_y      p_z       E        m'/)
76194  5200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
76195      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
76196      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
76197  5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
76198      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
76199      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
76200      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
76201  5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I  particle/jet',
76202      &     '  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)',1X
76203      &     ,'   C tag  AC tag'/)
76204  5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
76205  5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
76206  5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
76207  5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
76208  5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
76209  6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
76210  6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
76211  6200 FORMAT(66X,5(1X,F12.3))
76212  6300 FORMAT(1X,78('='))
76213  6400 FORMAT(1X,130('='))
76214  6500 FORMAT(1X,65('='))
76215  6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
76216  6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
76217  6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
76218  6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
76219      &5F13.5)
76220  7000 FORMAT(19X,'sum charge:',F6.2)
76221  7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
76222      &//'    I IST    ID   Mothers Daughters    p_x      p_y      p_z',
76223      &'       E        m')
76224  7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
76225  7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
76226      &//'   I IST     ID Mothers   Colours    p_x      p_y      p_z',
76227      &'       E        m')
76228  7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
76229  7500 FORMAT(///20X,'List of KF codes in program'/)
76230  7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
76231  7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
76232      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
76233      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
76234      &1X,'ME',3X,'Br.rat.',4X,'decay products')
76235  7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
76236      &1X,1P,E13.5,3X,I2)
76237  7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
76238  8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
76239      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
76240  8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
76241  
76242       RETURN
76243       END
76244  
76245 C*********************************************************************
76246  
76247 C...PYLOGO
76248 C...Writes a logo for the program.
76249  
76250       SUBROUTINE PYLOGO
76251  
76252 C...Double precision and integer declarations.
76253       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76254       IMPLICIT INTEGER(I-N)
76255       INTEGER PYK,PYCHGE,PYCOMP
76256 C...Parameter for length of information block.
76257       PARAMETER (IREFER=19)
76258 C...Commonblocks.
76259       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76260       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
76261       SAVE /PYDAT1/,/PYPARS/
76262 C...Local arrays and character variables.
76263       INTEGER IDATI(6)
76264       CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
76265      &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
76266  
76267 C...Data on months, logo, titles, and references.
76268       DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
76269      &'Oct','Nov','Dec'/
76270       DATA (LOGO(J),J=1,19)/
76271      &'            *......*            ',
76272      &'       *:::!!:::::::::::*       ',
76273      &'    *::::::!!::::::::::::::*    ',
76274      &'  *::::::::!!::::::::::::::::*  ',
76275      &' *:::::::::!!:::::::::::::::::* ',
76276      &' *:::::::::!!:::::::::::::::::* ',
76277      &'  *::::::::!!::::::::::::::::*! ',
76278      &'    *::::::!!::::::::::::::* !! ',
76279      &'    !! *:::!!:::::::::::*    !! ',
76280      &'    !!     !* -><- *         !! ',
76281      &'    !!     !!                !! ',
76282      &'    !!     !!                !! ',
76283      &'    !!                       !! ',
76284      &'    !!        lh             !! ',
76285      &'    !!                       !! ',
76286      &'    !!                 hh    !! ',
76287      &'    !!    ll                 !! ',
76288      &'    !!                       !! ',
76289      &'    !!                          '/
76290       DATA (LOGO(J),J=20,38)/
76291      &'Welcome to the Lund Monte Carlo!',
76292      &'                                ',
76293      &'PPP  Y   Y TTTTT H   H III   A  ',
76294      &'P  P  Y Y    T   H   H  I   A A ',
76295      &'PPP    Y     T   HHHHH  I  AAAAA',
76296      &'P      Y     T   H   H  I  A   A',
76297      &'P      Y     T   H   H III A   A',
76298      &'                                ',
76299      &'This is PYTHIA version x.xxx    ',
76300      &'Last date of change: xx xxx 201x',
76301      &'                                ',
76302      &'Now is xx xxx 201x at xx:xx:xx  ',
76303      &'                                ',
76304      &'Disclaimer: this program comes  ',
76305      &'without any guarantees. Beware  ',
76306      &'of errors and use common sense  ',
76307      &'when interpreting results.      ',
76308      &'                                ',
76309      &'Copyright T. Sjostrand (2011)   '/
76310       DATA (REFER(J),J=1,14)/
76311      &'An archive of program versions and d',
76312      &'ocumentation is found on the web:   ',
76313      &'http://www.thep.lu.se/~torbjorn/Pyth',
76314      &'ia.html                             ',
76315      &'                                    ',
76316      &'                                    ',
76317      &'When you cite this program, the offi',
76318      &'cial reference is to the 6.4 manual:',
76319      &'T. Sjostrand, S. Mrenna and P. Skand',
76320      &'s, JHEP05 (2006) 026                ',
76321      &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
76322      &'-T) [hep-ph/0603175].               ',
76323      &'                                    ',
76324      &'                                    '/
76325       DATA (REFER(J),J=15,32)/
76326      &'Also remember that the program, to a',
76327      &' large extent, represents original  ',
76328      &'physics research. Other publications',
76329      &' of special relevance to your       ',
76330      &'studies may therefore deserve separa',
76331      &'te mention.                         ',
76332      &'                                    ',
76333      &'                                    ',
76334      &'Main author: Torbjorn Sjostrand; Dep',
76335      &'artment of Theoretical Physics,     ',
76336      &'  Lund University, Solvegatan 14A, S',
76337      &'-223 62 Lund, Sweden;               ',
76338      &'  phone: + 46 - 46 - 222 48 16; e-ma',
76339      &'il: torbjorn@thep.lu.se             ',
76340      &'Author: Stephen Mrenna; Computing Di',
76341      &'vision, GDS Group,                  ',
76342      &'  Fermi National Accelerator Laborat',
76343      &'ory, MS 234, Batavia, IL 60510, USA;'/
76344       DATA (REFER(J),J=33,2*IREFER)/
76345      &'  phone: + 1 - 630 - 840 - 2556; e-m',
76346      &'ail: mrenna@fnal.gov                ',
76347      &'Author: Peter Skands; CERN/PH-TH, CH',
76348      &'-1211 Geneva, Switzerland           ',
76349      &'  phone: + 41 - 22 - 767 24 47; e-ma',
76350      &'il: peter.skands@cern.ch            '/
76351  
76352 C...Check that PYDATA linked (check we are in the year 20xx)
76353       IF(MSTP(183)/100.NE.20) THEN
76354         WRITE(*,'(1X,A)')
76355      &  'Error: PYDATA has not been linked.'
76356         WRITE(*,'(1X,A)') 'Execution stopped!'
76357         CALL PYSTOP(8)
76358  
76359 C...Write current version number and current date+time.
76360       ELSE
76361         WRITE(VERS,'(I1)') MSTP(181)
76362         LOGO(28)(24:24)=VERS
76363         WRITE(SUBV,'(I3)') MSTP(182)
76364         LOGO(28)(26:28)=SUBV
76365         IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
76366         WRITE(DATE,'(I2)') MSTP(185)
76367         LOGO(29)(22:23)=DATE
76368         LOGO(29)(25:27)=MONTH(MSTP(184))
76369         WRITE(YEAR,'(I4)') MSTP(183)
76370         LOGO(29)(29:32)=YEAR
76371         CALL PYTIME(IDATI)
76372         IF(IDATI(1).LE.0) THEN
76373           LOGO(31)='                                '
76374         ELSE
76375           WRITE(DATE,'(I2)') IDATI(3)
76376           LOGO(31)(8:9)=DATE
76377           LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
76378           WRITE(YEAR,'(I4)') IDATI(1)
76379           LOGO(31)(15:18)=YEAR
76380           WRITE(HOUR,'(I2)') IDATI(4)
76381           LOGO(31)(23:24)=HOUR
76382           WRITE(MINU,'(I2)') IDATI(5)
76383           LOGO(31)(26:27)=MINU
76384           IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
76385           WRITE(SECO,'(I2)') IDATI(6)
76386           LOGO(31)(29:30)=SECO
76387           IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
76388         ENDIF
76389       ENDIF
76390  
76391 C...Loop over lines in header. Define page feed and side borders.
76392       DO 100 ILIN=1,29+IREFER
76393         LINE=' '
76394         IF(ILIN.EQ.1) THEN
76395           LINE(1:1)='1'
76396         ELSE
76397           LINE(2:3)='**'
76398           LINE(78:79)='**'
76399         ENDIF
76400  
76401 C...Separator lines and logos.
76402         IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
76403           LINE(4:77)='***********************************************'//
76404      &    '***************************'
76405         ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
76406           LINE(6:37)=LOGO(ILIN-5)
76407           LINE(44:75)=LOGO(ILIN+14)
76408         ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
76409           LINE(5:40)=REFER(2*ILIN-51)
76410           LINE(41:76)=REFER(2*ILIN-50)
76411         ENDIF
76412  
76413 C...Write lines to appropriate unit.
76414         WRITE(MSTU(11),'(A79)') LINE
76415   100 CONTINUE
76416  
76417       RETURN
76418       END
76419  
76420 C*********************************************************************
76421  
76422 C...PYUPDA
76423 C...Facilitates the updating of particle and decay data
76424 C...by allowing it to be done in an external file.
76425  
76426       SUBROUTINE PYUPDA(MUPDA,LFN)
76427  
76428 C...Double precision and integer declarations.
76429       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76430       IMPLICIT INTEGER(I-N)
76431       INTEGER PYK,PYCHGE,PYCOMP
76432 C...Commonblocks.
76433       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76434       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76435       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
76436       COMMON/PYDAT4/CHAF(500,2)
76437       CHARACTER CHAF*16
76438       COMMON/PYINT4/MWID(500),WIDS(500,5)
76439       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
76440 C...Local arrays, character variables and data.
76441       CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
76442      &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
76443       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
76444      &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
76445      &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ',
76446      &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
76447      &'CHAF(I,1)','CHAF(I,2)','MWID(I)  '/
76448  
76449 C...Write header if not yet done.
76450       IF(MSTU(12).NE.12345) CALL PYLIST(0)
76451  
76452 C...Write information on file for editing.
76453       IF(MUPDA.EQ.1) THEN
76454         DO 110 KC=1,500
76455           WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
76456      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
76457      &    MWID(KC),MDCY(KC,1)
76458           DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
76459             WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
76460      &      (KFDP(IDC,J),J=1,5)
76461   100     CONTINUE
76462   110   CONTINUE
76463  
76464 C...Read complete set of information from edited file or
76465 C...read partial set of new or updated information from edited file.
76466       ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
76467  
76468 C...Reset counters.
76469         KCC=100
76470         NDC=0
76471         CHKF='         '
76472         IF(MUPDA.EQ.2) THEN
76473           DO 120 I=1,MSTU(6)
76474             KCHG(I,4)=0
76475   120     CONTINUE
76476         ELSE
76477           DO 130 KC=1,MSTU(6)
76478             IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
76479             NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
76480   130     CONTINUE
76481         ENDIF
76482  
76483 C...Begin of loop: read new line; unknown whether particle or
76484 C...decay data.
76485   140   READ(LFN,5200,END=190) CHINL
76486  
76487 C...Identify particle code and whether already defined  (for MUPDA=3).
76488         IF(CHINL(2:10).NE.'         ') THEN
76489           CHKF=CHINL(2:10)
76490           READ(CHKF,5300) KF
76491           IF(MUPDA.EQ.2) THEN
76492             IF(KF.LE.100) THEN
76493               KC=KF
76494             ELSE
76495               KCC=KCC+1
76496               KC=KCC
76497             ENDIF
76498           ELSE
76499             KCREP=0
76500             IF(KF.LE.100) THEN
76501               KCREP=KF
76502             ELSE
76503               DO 150 KCR=101,KCC
76504                 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
76505   150         CONTINUE
76506             ENDIF
76507 C...Remove duplicate old decay data.
76508             IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
76509               IDCREP=MDCY(KCREP,2)
76510               NDCREP=MDCY(KCREP,3)
76511               DO 160 I=1,KCC
76512                 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
76513   160         CONTINUE
76514               DO 180 I=IDCREP,NDC-NDCREP
76515                 MDME(I,1)=MDME(I+NDCREP,1)
76516                 MDME(I,2)=MDME(I+NDCREP,2)
76517                 BRAT(I)=BRAT(I+NDCREP)
76518                 DO 170 J=1,5
76519                   KFDP(I,J)=KFDP(I+NDCREP,J)
76520   170           CONTINUE
76521   180         CONTINUE
76522               NDC=NDC-NDCREP
76523               KC=KCREP
76524             ELSEIF(KCREP.NE.0) THEN
76525               KC=KCREP
76526             ELSE
76527               KCC=KCC+1
76528               KC=KCC
76529             ENDIF
76530           ENDIF
76531  
76532 C...Study line with particle data.
76533           IF(KC.GT.MSTU(6)) CALL PYERRM(27,
76534      &    '(PYUPDA:) Particle arrays full by KF ='//CHKF)
76535           READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
76536      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
76537      &    MWID(KC),MDCY(KC,1)
76538           MDCY(KC,2)=0
76539           MDCY(KC,3)=0
76540  
76541 C...Study line with decay data.
76542         ELSE
76543           NDC=NDC+1
76544           IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
76545      &    '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
76546           IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
76547           MDCY(KC,3)=MDCY(KC,3)+1
76548           READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
76549      &    (KFDP(NDC,J),J=1,5)
76550         ENDIF
76551  
76552 C...End of loop; ensure that PYCOMP tables are updated.
76553         GOTO 140
76554   190   CONTINUE
76555         MSTU(20)=0
76556  
76557 C...Perform possible tests that new information is consistent.
76558         DO 220 KC=1,MSTU(6)
76559           KF=KCHG(KC,4)
76560           IF(KF.EQ.0) GOTO 220
76561           WRITE(CHKF,5300) KF
76562           IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
76563      &    PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
76564      &    '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
76565           BRSUM=0D0
76566           DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
76567             IF(MDME(IDC,2).GT.80) GOTO 210
76568             KQ=KCHG(KC,1)
76569             PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
76570             MERR=0
76571             DO 200 J=1,5
76572               KP=KFDP(IDC,J)
76573               IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
76574                 IF(KP.EQ.81) KQ=0
76575               ELSEIF(PYCOMP(KP).EQ.0) THEN
76576                 MERR=3
76577               ELSE
76578                 KQ=KQ-PYCHGE(KP)
76579                 KPC=PYCOMP(KP)
76580                 PMS=PMS-PMAS(KPC,1)
76581                 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
76582      &          PMAS(KPC,3))
76583               ENDIF
76584   200       CONTINUE
76585             IF(KQ.NE.0) MERR=MAX(2,MERR)
76586             IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
76587      &      MERR=MAX(1,MERR)
76588             IF(MERR.EQ.3) CALL PYERRM(17,
76589      &      '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
76590             IF(MERR.EQ.2) CALL PYERRM(17,
76591      &      '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
76592             IF(MERR.EQ.1) CALL PYERRM(7,
76593      &      '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
76594             BRSUM=BRSUM+BRAT(IDC)
76595   210     CONTINUE
76596           WRITE(CHTMP,5500) BRSUM
76597           IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
76598      &    CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
76599      &    CHTMP(9:16)//' for KF ='//CHKF)
76600   220   CONTINUE
76601  
76602 C...Write DATA statements for inclusion in program.
76603       ELSEIF(MUPDA.EQ.4) THEN
76604  
76605 C...Find out how many codes and decay channels are actually used.
76606         KCC=0
76607         NDC=0
76608         DO 230 I=1,MSTU(6)
76609           IF(KCHG(I,4).NE.0) THEN
76610             KCC=I
76611             NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
76612           ENDIF
76613   230   CONTINUE
76614  
76615 C...Initialize writing of DATA statements for inclusion in program.
76616         DO 300 IVAR=1,22
76617           NDIM=MSTU(6)
76618           IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
76619           NLIN=1
76620           CHLIN=' '
76621           CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
76622           LLIN=35
76623           CHOLD='START'
76624  
76625 C...Loop through variables for conversion to characters.
76626           DO 280 IDIM=1,NDIM
76627             IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
76628             IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
76629             IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
76630             IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
76631             IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
76632             IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
76633             IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
76634             IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
76635             IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
76636             IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
76637             IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
76638             IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
76639             IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
76640             IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
76641             IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
76642             IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
76643             IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
76644             IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
76645             IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
76646             IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
76647             IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
76648             IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
76649  
76650 C...Replace variables beyond what is properly defined.
76651             IF(IVAR.LE.4) THEN
76652               IF(IDIM.GT.KCC) CHTMP='               0'
76653             ELSEIF(IVAR.LE.8) THEN
76654               IF(IDIM.GT.KCC) CHTMP='             0.0'
76655             ELSEIF(IVAR.LE.11) THEN
76656               IF(IDIM.GT.KCC) CHTMP='               0'
76657             ELSEIF(IVAR.LE.13) THEN
76658               IF(IDIM.GT.NDC) CHTMP='               0'
76659             ELSEIF(IVAR.LE.14) THEN
76660               IF(IDIM.GT.NDC) CHTMP='             0.0'
76661             ELSEIF(IVAR.LE.19) THEN
76662               IF(IDIM.GT.NDC) CHTMP='               0'
76663             ELSEIF(IVAR.LE.21) THEN
76664               IF(IDIM.GT.KCC) CHTMP='                '
76665             ELSE
76666               IF(IDIM.GT.KCC) CHTMP='               0'
76667             ENDIF
76668  
76669 C...Length of variable, trailing decimal zeros, quotation marks.
76670             LLOW=1
76671             LHIG=1
76672             DO 240 LL=1,16
76673               IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
76674               IF(CHTMP(LL:LL).NE.' ') LHIG=LL
76675   240       CONTINUE
76676             CHNEW=CHTMP(LLOW:LHIG)//' '
76677             LNEW=1+LHIG-LLOW
76678             IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
76679               LNEW=LNEW+1
76680   250         LNEW=LNEW-1
76681               IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
76682               IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
76683               IF(LNEW.EQ.0) THEN
76684                 CHNEW(1:3)='0D0'
76685                 LNEW=3
76686               ELSE
76687                 CHNEW(LNEW+1:LNEW+2)='D0'
76688                 LNEW=LNEW+2
76689               ENDIF
76690             ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
76691               DO 260 LL=LNEW,1,-1
76692                 IF(CHNEW(LL:LL).EQ.'''') THEN
76693                   CHTMP=CHNEW
76694                   CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
76695                   LNEW=LNEW+1
76696                 ENDIF
76697   260         CONTINUE
76698               LNEW=MIN(14,LNEW)
76699               CHTMP=CHNEW
76700               CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
76701               LNEW=LNEW+2
76702             ENDIF
76703  
76704 C...Form composite character string, often including repetition counter.
76705             IF(CHNEW.NE.CHOLD) THEN
76706               NRPT=1
76707               CHOLD=CHNEW
76708               CHCOM=CHNEW
76709               LCOM=LNEW
76710             ELSE
76711               LRPT=LNEW+1
76712               IF(NRPT.GE.2) LRPT=LNEW+3
76713               IF(NRPT.GE.10) LRPT=LNEW+4
76714               IF(NRPT.GE.100) LRPT=LNEW+5
76715               IF(NRPT.GE.1000) LRPT=LNEW+6
76716               LLIN=LLIN-LRPT
76717               NRPT=NRPT+1
76718               WRITE(CHTMP,5400) NRPT
76719               LRPT=1
76720               IF(NRPT.GE.10) LRPT=2
76721               IF(NRPT.GE.100) LRPT=3
76722               IF(NRPT.GE.1000) LRPT=4
76723               CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
76724               LCOM=LRPT+1+LNEW
76725             ENDIF
76726  
76727 C...Add characters to end of line, to new line (after storing old line),
76728 C...or to new block of lines (after writing old block).
76729             IF(LLIN+LCOM.LE.70) THEN
76730               CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
76731               LLIN=LLIN+LCOM+1
76732             ELSEIF(NLIN.LE.19) THEN
76733               CHLIN(LLIN+1:72)=' '
76734               CHBLK(NLIN)=CHLIN
76735               NLIN=NLIN+1
76736               CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
76737               LLIN=6+LCOM+1
76738             ELSE
76739               CHLIN(LLIN:72)='/'//' '
76740               CHBLK(NLIN)=CHLIN
76741               WRITE(CHTMP,5400) IDIM-NRPT
76742               CHBLK(1)(30:33)=CHTMP(13:16)
76743               DO 270 ILIN=1,NLIN
76744                 WRITE(LFN,5700) CHBLK(ILIN)
76745   270         CONTINUE
76746               NLIN=1
76747               CHLIN=' '
76748               CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
76749      &        ',I=    ,    )/'//CHCOM(1:LCOM)//','
76750               WRITE(CHTMP,5400) IDIM-NRPT+1
76751               CHLIN(25:28)=CHTMP(13:16)
76752               LLIN=35+LCOM+1
76753             ENDIF
76754   280     CONTINUE
76755  
76756 C...Write final block of lines.
76757           CHLIN(LLIN:72)='/'//' '
76758           CHBLK(NLIN)=CHLIN
76759           WRITE(CHTMP,5400) NDIM
76760           CHBLK(1)(30:33)=CHTMP(13:16)
76761           DO 290 ILIN=1,NLIN
76762             WRITE(LFN,5700) CHBLK(ILIN)
76763   290     CONTINUE
76764   300   CONTINUE
76765       ENDIF
76766  
76767 C...Formats for reading and writing particle data.
76768  5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
76769  5100 FORMAT(10X,2I5,F12.6,5I10)
76770  5200 FORMAT(A120)
76771  5300 FORMAT(I9)
76772  5400 FORMAT(I16)
76773  5500 FORMAT(F16.5)
76774  5600 FORMAT(F16.6)
76775  5700 FORMAT(A72)
76776  
76777       RETURN
76778       END
76779  
76780 C*********************************************************************
76781  
76782 C...PYK
76783 C...Provides various integer-valued event related data.
76784  
76785       FUNCTION PYK(I,J)
76786  
76787 C...Double precision and integer declarations.
76788       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76789       IMPLICIT INTEGER(I-N)
76790       INTEGER PYK,PYCHGE,PYCOMP
76791 C...Commonblocks.
76792       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76793       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76794       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76795       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76796  
76797 C...Default value. For I=0 number of entries, number of stable entries
76798 C...or 3 times total charge.
76799       PYK=0
76800       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
76801       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
76802         PYK=N
76803       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
76804         DO 100 I1=1,N
76805           IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
76806           IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
76807      &    PYCHGE(K(I1,2))
76808   100   CONTINUE
76809       ELSEIF(I.EQ.0) THEN
76810  
76811 C...For I > 0 direct readout of K matrix or charge.
76812       ELSEIF(J.LE.5) THEN
76813         PYK=K(I,J)
76814       ELSEIF(J.EQ.6) THEN
76815         PYK=PYCHGE(K(I,2))
76816  
76817 C...Status (existing/fragmented/decayed), parton/hadron separation.
76818       ELSEIF(J.LE.8) THEN
76819         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
76820         IF(J.EQ.8) PYK=PYK*K(I,2)
76821       ELSEIF(J.LE.12) THEN
76822         KFA=IABS(K(I,2))
76823         KC=PYCOMP(KFA)
76824         KQ=0
76825         IF(KC.NE.0) KQ=KCHG(KC,2)
76826         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
76827         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
76828         IF(J.EQ.11) PYK=KC
76829         IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
76830  
76831 C...Heaviest flavour in hadron/diquark.
76832       ELSEIF(J.EQ.13) THEN
76833         KFA=IABS(K(I,2))
76834         PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
76835         IF(KFA.LT.10) PYK=KFA
76836         IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
76837         PYK=PYK*ISIGN(1,K(I,2))
76838  
76839 C...Particle history: generation, ancestor, rank.
76840       ELSEIF(J.LE.15) THEN
76841         I2=I
76842         I1=I
76843   110   PYK=PYK+1
76844         I2=I1
76845         I1=K(I1,3)
76846         IF(I1.GT.0) THEN
76847           IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
76848         ENDIF
76849         IF(J.EQ.15) PYK=I2
76850       ELSEIF(J.EQ.16) THEN
76851         KFA=IABS(K(I,2))
76852         IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
76853      &  (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
76854           I1=I
76855   120     I2=I1
76856           I1=K(I1,3)
76857           IF(I1.GT.0) THEN
76858             KFAM=IABS(K(I1,2))
76859             ILP=1
76860             IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
76861             IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
76862      &      ILP=0
76863             IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
76864             IF(ILP.EQ.1) GOTO 120
76865           ENDIF
76866           IF(K(I1,1).EQ.12) THEN
76867             DO 130 I3=I1+1,I2
76868               IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
76869      &        .AND.K(I3,2).NE.93) PYK=PYK+1
76870   130       CONTINUE
76871           ELSE
76872             I3=I2
76873   140       PYK=PYK+1
76874             I3=I3+1
76875             IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
76876           ENDIF
76877         ENDIF
76878  
76879 C...Particle coming from collapsing jet system or not.
76880       ELSEIF(J.EQ.17) THEN
76881         I1=I
76882   150   PYK=PYK+1
76883         I3=I1
76884         I1=K(I1,3)
76885         I0=MAX(1,I1)
76886         KC=PYCOMP(K(I0,2))
76887         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
76888           IF(PYK.EQ.1) PYK=-1
76889           IF(PYK.GT.1) PYK=0
76890           RETURN
76891         ENDIF
76892         IF(KCHG(KC,2).EQ.0) GOTO 150
76893         IF(K(I1,1).NE.12) PYK=0
76894         IF(K(I1,1).NE.12) RETURN
76895         I2=I1
76896   160   I2=I2+1
76897         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
76898         K3M=K(I3-1,3)
76899         IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
76900         K3P=K(I3+1,3)
76901         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
76902  
76903 C...Number of decay products. Colour flow.
76904       ELSEIF(J.EQ.18) THEN
76905         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
76906         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
76907       ELSEIF(J.LE.22) THEN
76908         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
76909         IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
76910         IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
76911         IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
76912         IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
76913       ELSE
76914       ENDIF
76915  
76916       RETURN
76917       END
76918  
76919 C*********************************************************************
76920  
76921 C...PYP
76922 C...Provides various real-valued event related data.
76923  
76924       FUNCTION PYP(I,J)
76925  
76926 C...Double precision and integer declarations.
76927       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76928       IMPLICIT INTEGER(I-N)
76929       INTEGER PYK,PYCHGE,PYCOMP
76930 C...Commonblocks.
76931       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76932       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76933       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76934       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76935 C...Local array.
76936       DIMENSION PSUM(4)
76937  
76938 C...Set default value. For I = 0 sum of momenta or charges,
76939 C...or invariant mass of system.
76940       PYP=0D0
76941       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
76942       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
76943         DO 100 I1=1,N
76944           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
76945   100   CONTINUE
76946       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
76947         DO 120 J1=1,4
76948           PSUM(J1)=0D0
76949           DO 110 I1=1,N
76950             IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
76951      &      P(I1,J1)
76952   110     CONTINUE
76953   120   CONTINUE
76954         PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
76955       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
76956         DO 130 I1=1,N
76957           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
76958   130   CONTINUE
76959       ELSEIF(I.EQ.0) THEN
76960  
76961 C...Direct readout of P matrix.
76962       ELSEIF(J.LE.5) THEN
76963         PYP=P(I,J)
76964  
76965 C...Charge, total momentum, transverse momentum, transverse mass.
76966       ELSEIF(J.LE.12) THEN
76967         IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
76968         IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
76969         IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
76970         IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
76971         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
76972  
76973 C...Theta and phi angle in radians or degrees.
76974       ELSEIF(J.LE.16) THEN
76975         IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
76976         IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
76977         IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
76978  
76979 C...True rapidity, rapidity with pion mass, pseudorapidity.
76980       ELSEIF(J.LE.19) THEN
76981         PMR=0D0
76982         IF(J.EQ.17) PMR=P(I,5)
76983         IF(J.EQ.18) PMR=PYMASS(211)
76984         PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
76985         PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
76986      &  1D20)),P(I,3))
76987  
76988 C...Energy and momentum fractions (only to be used in CM frame).
76989       ELSEIF(J.LE.25) THEN
76990         IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
76991         IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
76992         IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
76993         IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
76994         IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
76995         IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
76996       ENDIF
76997  
76998       RETURN
76999       END
77000  
77001 C*********************************************************************
77002  
77003 C...PYSPHE
77004 C...Performs sphericity tensor analysis to give sphericity,
77005 C...aplanarity and the related event axes.
77006  
77007       SUBROUTINE PYSPHE(SPH,APL)
77008  
77009 C...Double precision and integer declarations.
77010       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77011       IMPLICIT INTEGER(I-N)
77012       INTEGER PYK,PYCHGE,PYCOMP
77013 C...Parameter statement to help give large particle numbers.
77014       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77015      &KEXCIT=4000000,KDIMEN=5000000)
77016 C...Commonblocks.
77017       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77018       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77019       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77020       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77021 C...Local arrays.
77022       DIMENSION SM(3,3),SV(3,3)
77023  
77024 C...Calculate matrix to be diagonalized.
77025       NP=0
77026       DO 110 J1=1,3
77027         DO 100 J2=J1,3
77028           SM(J1,J2)=0D0
77029   100   CONTINUE
77030   110 CONTINUE
77031       PS=0D0
77032       DO 140 I=1,N
77033         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
77034         IF(MSTU(41).GE.2) THEN
77035           KC=PYCOMP(K(I,2))
77036           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77037      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77038      &    K(I,2).EQ.KSUSY1+39) GOTO 140
77039           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77040      &    GOTO 140
77041         ENDIF
77042         NP=NP+1
77043         PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77044         PWT=1D0
77045         IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
77046      &  MAX(1D-10,PA)**(PARU(41)-2D0)
77047         DO 130 J1=1,3
77048           DO 120 J2=J1,3
77049             SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
77050   120     CONTINUE
77051   130   CONTINUE
77052         PS=PS+PWT*PA**2
77053   140 CONTINUE
77054  
77055 C...Very low multiplicities (0 or 1) not considered.
77056       IF(NP.LE.1) THEN
77057         CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
77058         SPH=-1D0
77059         APL=-1D0
77060         RETURN
77061       ENDIF
77062       DO 160 J1=1,3
77063         DO 150 J2=J1,3
77064           SM(J1,J2)=SM(J1,J2)/PS
77065   150   CONTINUE
77066   160 CONTINUE
77067  
77068 C...Find eigenvalues to matrix (third degree equation).
77069       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
77070      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
77071       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
77072      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
77073      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
77074       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
77075       P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
77076       P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
77077       P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
77078       IF(P(N+2,4).LT.1D-5) THEN
77079         CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
77080         SPH=-1D0
77081         APL=-1D0
77082         RETURN
77083       ENDIF
77084  
77085 C...Find first and last eigenvector by solving equation system.
77086       DO 240 I=1,3,2
77087         DO 180 J1=1,3
77088           SV(J1,J1)=SM(J1,J1)-P(N+I,4)
77089           DO 170 J2=J1+1,3
77090             SV(J1,J2)=SM(J1,J2)
77091             SV(J2,J1)=SM(J1,J2)
77092   170     CONTINUE
77093   180   CONTINUE
77094         SMAX=0D0
77095         DO 200 J1=1,3
77096           DO 190 J2=1,3
77097             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
77098             JA=J1
77099             JB=J2
77100             SMAX=ABS(SV(J1,J2))
77101   190     CONTINUE
77102   200   CONTINUE
77103         SMAX=0D0
77104         DO 220 J3=JA+1,JA+2
77105           J1=J3-3*((J3-1)/3)
77106           RL=SV(J1,JB)/SV(JA,JB)
77107           DO 210 J2=1,3
77108             SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
77109             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
77110             JC=J1
77111             SMAX=ABS(SV(J1,J2))
77112   210     CONTINUE
77113   220   CONTINUE
77114         JB1=JB+1-3*(JB/3)
77115         JB2=JB+2-3*((JB+1)/3)
77116         P(N+I,JB1)=-SV(JC,JB2)
77117         P(N+I,JB2)=SV(JC,JB1)
77118         P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
77119      &  SV(JA,JB)
77120         PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
77121         SGN=(-1D0)**INT(PYR(0)+0.5D0)
77122         DO 230 J=1,3
77123           P(N+I,J)=SGN*P(N+I,J)/PA
77124   230   CONTINUE
77125   240 CONTINUE
77126  
77127 C...Middle axis orthogonal to other two. Fill other codes.
77128       SGN=(-1D0)**INT(PYR(0)+0.5D0)
77129       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
77130       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
77131       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
77132       DO 260 I=1,3
77133         K(N+I,1)=31
77134         K(N+I,2)=95
77135         K(N+I,3)=I
77136         K(N+I,4)=0
77137         K(N+I,5)=0
77138         P(N+I,5)=0D0
77139         DO 250 J=1,5
77140           V(I,J)=0D0
77141   250   CONTINUE
77142   260 CONTINUE
77143  
77144 C...Calculate sphericity and aplanarity. Select storing option.
77145       SPH=1.5D0*(P(N+2,4)+P(N+3,4))
77146       APL=1.5D0*P(N+3,4)
77147       MSTU(61)=N+1
77148       MSTU(62)=NP
77149       IF(MSTU(43).LE.1) MSTU(3)=3
77150       IF(MSTU(43).GE.2) N=N+3
77151  
77152       RETURN
77153       END
77154  
77155 C*********************************************************************
77156  
77157 C...PYTHRU
77158 C...Performs thrust analysis to give thrust, oblateness
77159 C...and the related event axes.
77160  
77161       SUBROUTINE PYTHRU(THR,OBL)
77162  
77163 C...Double precision and integer declarations.
77164       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77165       IMPLICIT INTEGER(I-N)
77166       INTEGER PYK,PYCHGE,PYCOMP
77167 C...Parameter statement to help give large particle numbers.
77168       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77169      &KEXCIT=4000000,KDIMEN=5000000)
77170 C...Commonblocks.
77171       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77172       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77173       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77174       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77175 C...Local arrays.
77176       DIMENSION TDI(3),TPR(3)
77177  
77178 C...Take copy of particles that are to be considered in thrust analysis.
77179       NP=0
77180       PS=0D0
77181       DO 100 I=1,N
77182         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
77183         IF(MSTU(41).GE.2) THEN
77184           KC=PYCOMP(K(I,2))
77185           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77186      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77187      &    K(I,2).EQ.KSUSY1+39) GOTO 100
77188           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77189      &    GOTO 100
77190         ENDIF
77191         IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
77192           CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
77193           THR=-2D0
77194           OBL=-2D0
77195           RETURN
77196         ENDIF
77197         NP=NP+1
77198         K(N+NP,1)=23
77199         P(N+NP,1)=P(I,1)
77200         P(N+NP,2)=P(I,2)
77201         P(N+NP,3)=P(I,3)
77202         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77203         P(N+NP,5)=1D0
77204         IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
77205      &  P(N+NP,4)**(PARU(42)-1D0)
77206         PS=PS+P(N+NP,4)*P(N+NP,5)
77207   100 CONTINUE
77208  
77209 C...Very low multiplicities (0 or 1) not considered.
77210       IF(NP.LE.1) THEN
77211         CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
77212         THR=-1D0
77213         OBL=-1D0
77214         RETURN
77215       ENDIF
77216  
77217 C...Loop over thrust and major. T axis along z direction in latter case.
77218       DO 320 ILD=1,2
77219         IF(ILD.EQ.2) THEN
77220           K(N+NP+1,1)=31
77221           PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
77222           MSTU(33)=1
77223           CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
77224           THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
77225           CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
77226         ENDIF
77227  
77228 C...Find and order particles with highest p (pT for major).
77229         DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
77230           P(ILF,4)=0D0
77231   110   CONTINUE
77232         DO 160 I=N+1,N+NP
77233           IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
77234           DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
77235             IF(P(I,4).LE.P(ILF,4)) GOTO 140
77236             DO 120 J=1,5
77237               P(ILF+1,J)=P(ILF,J)
77238   120       CONTINUE
77239   130     CONTINUE
77240           ILF=N+NP+3
77241   140     DO 150 J=1,5
77242             P(ILF+1,J)=P(I,J)
77243   150     CONTINUE
77244   160   CONTINUE
77245  
77246 C...Find and order initial axes with highest thrust (major).
77247         DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
77248           P(ILG,4)=0D0
77249   170   CONTINUE
77250         NC=2**(MIN(MSTU(44),NP)-1)
77251         DO 250 ILC=1,NC
77252           DO 180 J=1,3
77253             TDI(J)=0D0
77254   180     CONTINUE
77255           DO 200 ILF=1,MIN(MSTU(44),NP)
77256             SGN=P(N+NP+ILF+3,5)
77257             IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
77258             DO 190 J=1,4-ILD
77259               TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
77260   190       CONTINUE
77261   200     CONTINUE
77262           TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
77263           DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
77264             IF(TDS.LE.P(ILG,4)) GOTO 230
77265             DO 210 J=1,4
77266               P(ILG+1,J)=P(ILG,J)
77267   210       CONTINUE
77268   220     CONTINUE
77269           ILG=N+NP+MSTU(44)+4
77270   230     DO 240 J=1,3
77271             P(ILG+1,J)=TDI(J)
77272   240     CONTINUE
77273           P(ILG+1,4)=TDS
77274   250   CONTINUE
77275  
77276 C...Iterate direction of axis until stable maximum.
77277         P(N+NP+ILD,4)=0D0
77278         ILG=0
77279   260   ILG=ILG+1
77280         THP=0D0
77281   270   THPS=THP
77282         DO 280 J=1,3
77283           IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
77284           IF(THP.GT.1D-10) TDI(J)=TPR(J)
77285           TPR(J)=0D0
77286   280   CONTINUE
77287         DO 300 I=N+1,N+NP
77288           SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
77289           DO 290 J=1,4-ILD
77290             TPR(J)=TPR(J)+SGN*P(I,J)
77291   290     CONTINUE
77292   300   CONTINUE
77293         THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
77294         IF(THP.GE.THPS+PARU(48)) GOTO 270
77295  
77296 C...Save good axis. Try new initial axis until a number of tries agree.
77297         IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
77298         IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
77299           IAGR=0
77300           SGN=(-1D0)**INT(PYR(0)+0.5D0)
77301           DO 310 J=1,3
77302             P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
77303   310     CONTINUE
77304           P(N+NP+ILD,4)=THP
77305           P(N+NP+ILD,5)=0D0
77306         ENDIF
77307         IAGR=IAGR+1
77308         IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
77309   320 CONTINUE
77310  
77311 C...Find minor axis and value by orthogonality.
77312       SGN=(-1D0)**INT(PYR(0)+0.5D0)
77313       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
77314       P(N+NP+3,2)=SGN*P(N+NP+2,1)
77315       P(N+NP+3,3)=0D0
77316       THP=0D0
77317       DO 330 I=N+1,N+NP
77318         THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
77319   330 CONTINUE
77320       P(N+NP+3,4)=THP/PS
77321       P(N+NP+3,5)=0D0
77322  
77323 C...Fill axis information. Rotate back to original coordinate system.
77324       DO 350 ILD=1,3
77325         K(N+ILD,1)=31
77326         K(N+ILD,2)=96
77327         K(N+ILD,3)=ILD
77328         K(N+ILD,4)=0
77329         K(N+ILD,5)=0
77330         DO 340 J=1,5
77331           P(N+ILD,J)=P(N+NP+ILD,J)
77332           V(N+ILD,J)=0D0
77333   340   CONTINUE
77334   350 CONTINUE
77335       CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
77336  
77337 C...Calculate thrust and oblateness. Select storing option.
77338       THR=P(N+1,4)
77339       OBL=P(N+2,4)-P(N+3,4)
77340       MSTU(61)=N+1
77341       MSTU(62)=NP
77342       IF(MSTU(43).LE.1) MSTU(3)=3
77343       IF(MSTU(43).GE.2) N=N+3
77344  
77345       RETURN
77346       END
77347  
77348 C*********************************************************************
77349  
77350 C...PYCLUS
77351 C...Subdivides the particle content of an event into jets/clusters.
77352  
77353       SUBROUTINE PYCLUS(NJET)
77354  
77355 C...Double precision and integer declarations.
77356       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77357       IMPLICIT INTEGER(I-N)
77358       INTEGER PYK,PYCHGE,PYCOMP
77359 C...Parameter statement to help give large particle numbers.
77360       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77361      &KEXCIT=4000000,KDIMEN=5000000)
77362 C...Commonblocks.
77363       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77364       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77365       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77366       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77367 C...Local arrays and saved variables.
77368       DIMENSION PS(5)
77369       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
77370  
77371 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
77372       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
77373      &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
77374       R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
77375      &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
77376       R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
77377      &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
77378  
77379 C...If first time, reset. If reentering, skip preliminaries.
77380       IF(MSTU(48).LE.0) THEN
77381         NP=0
77382         DO 100 J=1,5
77383           PS(J)=0D0
77384   100   CONTINUE
77385         PSS=0D0
77386         PIMASS=PMAS(PYCOMP(211),1)
77387       ELSE
77388         NJET=NSAV
77389         IF(MSTU(43).GE.2) N=N-NJET
77390         DO 110 I=N+1,N+NJET
77391           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77392   110   CONTINUE
77393         IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
77394           R2ACC=PARU(44)**2
77395         ELSE
77396           R2ACC=PARU(45)*PS(5)**2
77397         ENDIF
77398         NLOOP=0
77399         GOTO 300
77400       ENDIF
77401  
77402 C...Find which particles are to be considered in cluster search.
77403       DO 140 I=1,N
77404         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
77405         IF(MSTU(41).GE.2) THEN
77406           KC=PYCOMP(K(I,2))
77407           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77408      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77409      &    K(I,2).EQ.KSUSY1+39) GOTO 140
77410           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77411      &    GOTO 140
77412         ENDIF
77413         IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
77414           CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
77415           NJET=-1
77416           RETURN
77417         ENDIF
77418  
77419 C...Take copy of these particles, with space left for jets later on.
77420         NP=NP+1
77421         K(N+NP,3)=I
77422         DO 120 J=1,5
77423           P(N+NP,J)=P(I,J)
77424   120   CONTINUE
77425         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
77426         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
77427         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77428         P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77429         DO 130 J=1,4
77430           PS(J)=PS(J)+P(N+NP,J)
77431   130   CONTINUE
77432         PSS=PSS+P(N+NP,5)
77433   140 CONTINUE
77434       DO 160 I=N+1,N+NP
77435         K(I+NP,3)=K(I,3)
77436         DO 150 J=1,5
77437           P(I+NP,J)=P(I,J)
77438   150   CONTINUE
77439   160 CONTINUE
77440       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
77441  
77442 C...Very low multiplicities not considered.
77443       IF(NP.LT.MSTU(47)) THEN
77444         CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
77445         NJET=-1
77446         RETURN
77447       ENDIF
77448  
77449 C...Find precluster configuration. If too few jets, make harder cuts.
77450       NLOOP=0
77451       IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
77452         R2ACC=PARU(44)**2
77453       ELSE
77454         R2ACC=PARU(45)*PS(5)**2
77455       ENDIF
77456       RINIT=1.25D0*PARU(43)
77457       IF(NP.LE.MSTU(47)+2) RINIT=0D0
77458   170 RINIT=0.8D0*RINIT
77459       NPRE=0
77460       NREM=NP
77461       DO 180 I=N+NP+1,N+2*NP
77462         K(I,4)=0
77463   180 CONTINUE
77464  
77465 C...Sum up small momentum region. Jet if enough absolute momentum.
77466       IF(MSTU(46).LE.2) THEN
77467         DO 190 J=1,4
77468           P(N+1,J)=0D0
77469   190   CONTINUE
77470         DO 210 I=N+NP+1,N+2*NP
77471           IF(P(I,5).GT.2D0*RINIT) GOTO 210
77472           NREM=NREM-1
77473           K(I,4)=1
77474           DO 200 J=1,4
77475             P(N+1,J)=P(N+1,J)+P(I,J)
77476   200     CONTINUE
77477   210   CONTINUE
77478         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
77479         IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
77480         IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
77481         IF(NREM.EQ.0) GOTO 170
77482       ENDIF
77483  
77484 C...Find fastest remaining particle.
77485   220 NPRE=NPRE+1
77486       PMAX=0D0
77487       DO 230 I=N+NP+1,N+2*NP
77488         IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
77489         IMAX=I
77490         PMAX=P(I,5)
77491   230 CONTINUE
77492       DO 240 J=1,5
77493         P(N+NPRE,J)=P(IMAX,J)
77494   240 CONTINUE
77495       NREM=NREM-1
77496       K(IMAX,4)=NPRE
77497  
77498 C...Sum up precluster around it according to pT separation.
77499       IF(MSTU(46).LE.2) THEN
77500         DO 260 I=N+NP+1,N+2*NP
77501           IF(K(I,4).NE.0) GOTO 260
77502           R2=R2T(I,IMAX)
77503           IF(R2.GT.RINIT**2) GOTO 260
77504           NREM=NREM-1
77505           K(I,4)=NPRE
77506           DO 250 J=1,4
77507             P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
77508   250     CONTINUE
77509   260   CONTINUE
77510         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
77511  
77512 C...Sum up precluster around it according to mass or
77513 C...Durham pT separation.
77514       ELSE
77515   270   IMIN=0
77516         R2MIN=RINIT**2
77517         DO 280 I=N+NP+1,N+2*NP
77518           IF(K(I,4).NE.0) GOTO 280
77519           IF(MSTU(46).LE.4) THEN
77520             R2=R2M(I,N+NPRE)
77521           ELSE
77522             R2=R2D(I,N+NPRE)
77523           ENDIF
77524           IF(R2.GE.R2MIN) GOTO 280
77525           IMIN=I
77526           R2MIN=R2
77527   280   CONTINUE
77528         IF(IMIN.NE.0) THEN
77529           DO 290 J=1,4
77530             P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
77531   290     CONTINUE
77532           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
77533           NREM=NREM-1
77534           K(IMIN,4)=NPRE
77535           GOTO 270
77536         ENDIF
77537       ENDIF
77538  
77539 C...Check if more preclusters to be found. Start over if too few.
77540       IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
77541       IF(NREM.GT.0) GOTO 220
77542       NJET=NPRE
77543  
77544 C...Reassign all particles to nearest jet. Sum up new jet momenta.
77545   300 TSAV=0D0
77546       PSJT=0D0
77547   310 IF(MSTU(46).LE.1) THEN
77548         DO 330 I=N+1,N+NJET
77549           DO 320 J=1,4
77550             V(I,J)=0D0
77551   320     CONTINUE
77552   330   CONTINUE
77553         DO 360 I=N+NP+1,N+2*NP
77554           R2MIN=PSS**2
77555           DO 340 IJET=N+1,N+NJET
77556             IF(P(IJET,5).LT.RINIT) GOTO 340
77557             R2=R2T(I,IJET)
77558             IF(R2.GE.R2MIN) GOTO 340
77559             IMIN=IJET
77560             R2MIN=R2
77561   340     CONTINUE
77562           K(I,4)=IMIN-N
77563           DO 350 J=1,4
77564             V(IMIN,J)=V(IMIN,J)+P(I,J)
77565   350     CONTINUE
77566   360   CONTINUE
77567         PSJT=0D0
77568         DO 380 I=N+1,N+NJET
77569           DO 370 J=1,4
77570             P(I,J)=V(I,J)
77571   370     CONTINUE
77572           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77573           PSJT=PSJT+P(I,5)
77574   380   CONTINUE
77575       ENDIF
77576  
77577 C...Find two closest jets.
77578       R2MIN=2D0*MAX(R2ACC,PS(5)**2)
77579       DO 400 ITRY1=N+1,N+NJET-1
77580         DO 390 ITRY2=ITRY1+1,N+NJET
77581           IF(MSTU(46).LE.2) THEN
77582             R2=R2T(ITRY1,ITRY2)
77583           ELSEIF(MSTU(46).LE.4) THEN
77584             R2=R2M(ITRY1,ITRY2)
77585           ELSE
77586             R2=R2D(ITRY1,ITRY2)
77587           ENDIF
77588           IF(R2.GE.R2MIN) GOTO 390
77589           IMIN1=ITRY1
77590           IMIN2=ITRY2
77591           R2MIN=R2
77592   390   CONTINUE
77593   400 CONTINUE
77594  
77595 C...If allowed, join two closest jets and start over.
77596       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
77597         IREC=MIN(IMIN1,IMIN2)
77598         IDEL=MAX(IMIN1,IMIN2)
77599         DO 410 J=1,4
77600           P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
77601   410   CONTINUE
77602         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
77603         DO 430 I=IDEL+1,N+NJET
77604           DO 420 J=1,5
77605             P(I-1,J)=P(I,J)
77606   420     CONTINUE
77607   430   CONTINUE
77608         IF(MSTU(46).GE.2) THEN
77609           DO 440 I=N+NP+1,N+2*NP
77610             IORI=N+K(I,4)
77611             IF(IORI.EQ.IDEL) K(I,4)=IREC-N
77612             IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
77613   440     CONTINUE
77614         ENDIF
77615         NJET=NJET-1
77616         GOTO 300
77617  
77618 C...Divide up broad jet if empty cluster in list of final ones.
77619       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
77620         DO 450 I=N+1,N+NJET
77621           K(I,5)=0
77622   450   CONTINUE
77623         DO 460 I=N+NP+1,N+2*NP
77624           K(N+K(I,4),5)=K(N+K(I,4),5)+1
77625   460   CONTINUE
77626         IEMP=0
77627         DO 470 I=N+1,N+NJET
77628           IF(K(I,5).EQ.0) IEMP=I
77629   470   CONTINUE
77630         IF(IEMP.NE.0) THEN
77631           NLOOP=NLOOP+1
77632           ISPL=0
77633           R2MAX=0D0
77634           DO 480 I=N+NP+1,N+2*NP
77635             IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
77636             IJET=N+K(I,4)
77637             R2=R2T(I,IJET)
77638             IF(R2.LE.R2MAX) GOTO 480
77639             ISPL=I
77640             R2MAX=R2
77641   480     CONTINUE
77642           IF(ISPL.NE.0) THEN
77643             IJET=N+K(ISPL,4)
77644             DO 490 J=1,4
77645               P(IEMP,J)=P(ISPL,J)
77646               P(IJET,J)=P(IJET,J)-P(ISPL,J)
77647   490       CONTINUE
77648             P(IEMP,5)=P(ISPL,5)
77649             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
77650             IF(NLOOP.LE.2) GOTO 300
77651           ENDIF
77652         ENDIF
77653       ENDIF
77654  
77655 C...If generalized thrust has not yet converged, continue iteration.
77656       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
77657      &THEN
77658         TSAV=PSJT/PSS
77659         GOTO 310
77660       ENDIF
77661  
77662 C...Reorder jets according to energy.
77663       DO 510 I=N+1,N+NJET
77664         DO 500 J=1,5
77665           V(I,J)=P(I,J)
77666   500   CONTINUE
77667   510 CONTINUE
77668       DO 540 INEW=N+1,N+NJET
77669         PEMAX=0D0
77670         DO 520 ITRY=N+1,N+NJET
77671           IF(V(ITRY,4).LE.PEMAX) GOTO 520
77672           IMAX=ITRY
77673           PEMAX=V(ITRY,4)
77674   520   CONTINUE
77675         K(INEW,1)=31
77676         K(INEW,2)=97
77677         K(INEW,3)=INEW-N
77678         K(INEW,4)=0
77679         DO 530 J=1,5
77680           P(INEW,J)=V(IMAX,J)
77681   530   CONTINUE
77682         V(IMAX,4)=-1D0
77683         K(IMAX,5)=INEW
77684   540 CONTINUE
77685  
77686 C...Clean up particle-jet assignments and jet information.
77687       DO 550 I=N+NP+1,N+2*NP
77688         IORI=K(N+K(I,4),5)
77689         K(I,4)=IORI-N
77690         IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
77691         K(IORI,4)=K(IORI,4)+1
77692   550 CONTINUE
77693       IEMP=0
77694       PSJT=0D0
77695       DO 570 I=N+1,N+NJET
77696         K(I,5)=0
77697         PSJT=PSJT+P(I,5)
77698         P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
77699         DO 560 J=1,5
77700           V(I,J)=0D0
77701   560   CONTINUE
77702         IF(K(I,4).EQ.0) IEMP=I
77703   570 CONTINUE
77704  
77705 C...Select storing option. Output variables. Check for failure.
77706       MSTU(61)=N+1
77707       MSTU(62)=NP
77708       MSTU(63)=NPRE
77709       PARU(61)=PS(5)
77710       PARU(62)=PSJT/PSS
77711       PARU(63)=SQRT(R2MIN)
77712       IF(NJET.LE.1) PARU(63)=0D0
77713       IF(IEMP.NE.0) THEN
77714         CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
77715         NJET=-1
77716         RETURN
77717       ENDIF
77718       IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
77719       IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
77720       NSAV=NJET
77721  
77722       RETURN
77723       END
77724  
77725 C*********************************************************************
77726  
77727 C...PYCELL
77728 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
77729 C...as used for calorimeters at hadron colliders.
77730  
77731       SUBROUTINE PYCELL(NJET)
77732  
77733 C...Double precision and integer declarations.
77734       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77735       IMPLICIT INTEGER(I-N)
77736       INTEGER PYK,PYCHGE,PYCOMP
77737 C...Parameter statement to help give large particle numbers.
77738       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77739      &KEXCIT=4000000,KDIMEN=5000000)
77740 C...Commonblocks.
77741       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77742       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77743       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77744       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77745  
77746 C...Loop over all particles. Find cell that was hit by given particle.
77747       PTLRAT=1D0/SINH(PARU(51))**2
77748       NP=0
77749       NC=N
77750       DO 110 I=1,N
77751         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
77752         IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
77753         IF(MSTU(41).GE.2) THEN
77754           KC=PYCOMP(K(I,2))
77755           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77756      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77757      &    K(I,2).EQ.KSUSY1+39) GOTO 110
77758           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77759      &    GOTO 110
77760         ENDIF
77761         NP=NP+1
77762         PT=SQRT(P(I,1)**2+P(I,2)**2)
77763         ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
77764         IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
77765      &  (ETA/PARU(51)+1D0))))
77766         PHI=PYANGL(P(I,1),P(I,2))
77767         IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
77768      &  (PHI/PARU(1)+1D0))))
77769         IETPH=MSTU(52)*IETA+IPHI
77770  
77771 C...Add to cell already hit, or book new cell.
77772         DO 100 IC=N+1,NC
77773           IF(IETPH.EQ.K(IC,3)) THEN
77774             K(IC,4)=K(IC,4)+1
77775             P(IC,5)=P(IC,5)+PT
77776             GOTO 110
77777           ENDIF
77778   100   CONTINUE
77779         IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
77780           CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
77781           NJET=-2
77782           RETURN
77783         ENDIF
77784         NC=NC+1
77785         K(NC,3)=IETPH
77786         K(NC,4)=1
77787         K(NC,5)=2
77788         P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
77789         P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
77790         P(NC,5)=PT
77791   110 CONTINUE
77792  
77793 C...Smear true bin content by calorimeter resolution.
77794       IF(MSTU(53).GE.1) THEN
77795         DO 130 IC=N+1,NC
77796           PEI=P(IC,5)
77797           IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
77798   120     PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
77799      &    COS(PARU(2)*PYR(0))
77800           IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
77801           P(IC,5)=PEF
77802           IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
77803   130   CONTINUE
77804       ENDIF
77805  
77806 C...Remove cells below threshold.
77807       IF(PARU(58).GT.0D0) THEN
77808         NCC=NC
77809         NC=N
77810         DO 140 IC=N+1,NCC
77811           IF(P(IC,5).GT.PARU(58)) THEN
77812             NC=NC+1
77813             K(NC,3)=K(IC,3)
77814             K(NC,4)=K(IC,4)
77815             K(NC,5)=K(IC,5)
77816             P(NC,1)=P(IC,1)
77817             P(NC,2)=P(IC,2)
77818             P(NC,5)=P(IC,5)
77819           ENDIF
77820   140   CONTINUE
77821       ENDIF
77822  
77823 C...Find initiator cell: the one with highest pT of not yet used ones.
77824       NJ=NC
77825   150 ETMAX=0D0
77826       DO 160 IC=N+1,NC
77827         IF(K(IC,5).NE.2) GOTO 160
77828         IF(P(IC,5).LE.ETMAX) GOTO 160
77829         ICMAX=IC
77830         ETA=P(IC,1)
77831         PHI=P(IC,2)
77832         ETMAX=P(IC,5)
77833   160 CONTINUE
77834       IF(ETMAX.LT.PARU(52)) GOTO 220
77835       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
77836         CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
77837         NJET=-2
77838         RETURN
77839       ENDIF
77840       K(ICMAX,5)=1
77841       NJ=NJ+1
77842       K(NJ,4)=0
77843       K(NJ,5)=1
77844       P(NJ,1)=ETA
77845       P(NJ,2)=PHI
77846       P(NJ,3)=0D0
77847       P(NJ,4)=0D0
77848       P(NJ,5)=0D0
77849  
77850 C...Sum up unused cells within required distance of initiator.
77851       DO 170 IC=N+1,NC
77852         IF(K(IC,5).EQ.0) GOTO 170
77853         IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
77854         DPHIA=ABS(P(IC,2)-PHI)
77855         IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
77856         PHIC=P(IC,2)
77857         IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
77858         IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
77859         K(IC,5)=-K(IC,5)
77860         K(NJ,4)=K(NJ,4)+K(IC,4)
77861         P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
77862         P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
77863         P(NJ,5)=P(NJ,5)+P(IC,5)
77864   170 CONTINUE
77865  
77866 C...Reject cluster below minimum ET, else accept.
77867       IF(P(NJ,5).LT.PARU(53)) THEN
77868         NJ=NJ-1
77869         DO 180 IC=N+1,NC
77870           IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
77871   180   CONTINUE
77872       ELSEIF(MSTU(54).LE.2) THEN
77873         P(NJ,3)=P(NJ,3)/P(NJ,5)
77874         P(NJ,4)=P(NJ,4)/P(NJ,5)
77875         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
77876      &  P(NJ,4))
77877         DO 190 IC=N+1,NC
77878           IF(K(IC,5).LT.0) K(IC,5)=0
77879   190   CONTINUE
77880       ELSE
77881         DO 200 J=1,4
77882           P(NJ,J)=0D0
77883   200   CONTINUE
77884         DO 210 IC=N+1,NC
77885           IF(K(IC,5).GE.0) GOTO 210
77886           P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
77887           P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
77888           P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
77889           P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
77890           K(IC,5)=0
77891   210   CONTINUE
77892       ENDIF
77893       GOTO 150
77894  
77895 C...Arrange clusters in falling ET sequence.
77896   220 DO 250 I=1,NJ-NC
77897         ETMAX=0D0
77898         DO 230 IJ=NC+1,NJ
77899           IF(K(IJ,5).EQ.0) GOTO 230
77900           IF(P(IJ,5).LT.ETMAX) GOTO 230
77901           IJMAX=IJ
77902           ETMAX=P(IJ,5)
77903   230   CONTINUE
77904         K(IJMAX,5)=0
77905         K(N+I,1)=31
77906         K(N+I,2)=98
77907         K(N+I,3)=I
77908         K(N+I,4)=K(IJMAX,4)
77909         K(N+I,5)=0
77910         DO 240 J=1,5
77911           P(N+I,J)=P(IJMAX,J)
77912           V(N+I,J)=0D0
77913   240   CONTINUE
77914   250 CONTINUE
77915       NJET=NJ-NC
77916  
77917 C...Convert to massless or massive four-vectors.
77918       IF(MSTU(54).EQ.2) THEN
77919         DO 260 I=N+1,N+NJET
77920           ETA=P(I,3)
77921           P(I,1)=P(I,5)*COS(P(I,4))
77922           P(I,2)=P(I,5)*SIN(P(I,4))
77923           P(I,3)=P(I,5)*SINH(ETA)
77924           P(I,4)=P(I,5)*COSH(ETA)
77925           P(I,5)=0D0
77926   260   CONTINUE
77927       ELSEIF(MSTU(54).GE.3) THEN
77928         DO 270 I=N+1,N+NJET
77929           P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
77930   270   CONTINUE
77931       ENDIF
77932  
77933 C...Information about storage.
77934       MSTU(61)=N+1
77935       MSTU(62)=NP
77936       MSTU(63)=NC-N
77937       IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
77938       IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
77939  
77940       RETURN
77941       END
77942  
77943 C*********************************************************************
77944  
77945 C...PYJMAS
77946 C...Determines, approximately, the two jet masses that minimize
77947 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
77948  
77949       SUBROUTINE PYJMAS(PMH,PML)
77950  
77951 C...Double precision and integer declarations.
77952       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77953       IMPLICIT INTEGER(I-N)
77954       INTEGER PYK,PYCHGE,PYCOMP
77955 C...Parameter statement to help give large particle numbers.
77956       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77957      &KEXCIT=4000000,KDIMEN=5000000)
77958 C...Commonblocks.
77959       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77960       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77961       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77962       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77963 C...Local arrays.
77964       DIMENSION SM(3,3),SAX(3),PS(3,5)
77965  
77966 C...Reset.
77967       NP=0
77968       DO 120 J1=1,3
77969         DO 100 J2=J1,3
77970           SM(J1,J2)=0D0
77971   100   CONTINUE
77972         DO 110 J2=1,4
77973           PS(J1,J2)=0D0
77974   110   CONTINUE
77975   120 CONTINUE
77976       PSS=0D0
77977       PIMASS=PMAS(PYCOMP(211),1)
77978  
77979 C...Take copy of particles that are to be considered in mass analysis.
77980       DO 170 I=1,N
77981         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
77982         IF(MSTU(41).GE.2) THEN
77983           KC=PYCOMP(K(I,2))
77984           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77985      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77986      &    K(I,2).EQ.KSUSY1+39) GOTO 170
77987           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77988      &    GOTO 170
77989         ENDIF
77990         IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
77991           CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
77992           PMH=-2D0
77993           PML=-2D0
77994           RETURN
77995         ENDIF
77996         NP=NP+1
77997         DO 130 J=1,5
77998           P(N+NP,J)=P(I,J)
77999   130   CONTINUE
78000         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
78001         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
78002         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
78003  
78004 C...Fill information in sphericity tensor and total momentum vector.
78005         DO 150 J1=1,3
78006           DO 140 J2=J1,3
78007             SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
78008   140     CONTINUE
78009   150   CONTINUE
78010         PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
78011         DO 160 J=1,4
78012           PS(3,J)=PS(3,J)+P(N+NP,J)
78013   160   CONTINUE
78014   170 CONTINUE
78015  
78016 C...Very low multiplicities (0 or 1) not considered.
78017       IF(NP.LE.1) THEN
78018         CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
78019         PMH=-1D0
78020         PML=-1D0
78021         RETURN
78022       ENDIF
78023       PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
78024      &PS(3,3)**2))
78025  
78026 C...Find largest eigenvalue to matrix (third degree equation).
78027       DO 190 J1=1,3
78028         DO 180 J2=J1,3
78029           SM(J1,J2)=SM(J1,J2)/PSS
78030   180   CONTINUE
78031   190 CONTINUE
78032       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
78033      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
78034       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
78035      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
78036      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
78037       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
78038       SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
78039  
78040 C...Find largest eigenvector by solving equation system.
78041       DO 210 J1=1,3
78042         SM(J1,J1)=SM(J1,J1)-SMA
78043         DO 200 J2=J1+1,3
78044           SM(J2,J1)=SM(J1,J2)
78045   200   CONTINUE
78046   210 CONTINUE
78047       SMAX=0D0
78048       DO 230 J1=1,3
78049         DO 220 J2=1,3
78050           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
78051           JA=J1
78052           JB=J2
78053           SMAX=ABS(SM(J1,J2))
78054   220   CONTINUE
78055   230 CONTINUE
78056       SMAX=0D0
78057       DO 250 J3=JA+1,JA+2
78058         J1=J3-3*((J3-1)/3)
78059         RL=SM(J1,JB)/SM(JA,JB)
78060         DO 240 J2=1,3
78061           SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
78062           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
78063           JC=J1
78064           SMAX=ABS(SM(J1,J2))
78065   240   CONTINUE
78066   250 CONTINUE
78067       JB1=JB+1-3*(JB/3)
78068       JB2=JB+2-3*((JB+1)/3)
78069       SAX(JB1)=-SM(JC,JB2)
78070       SAX(JB2)=SM(JC,JB1)
78071       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
78072  
78073 C...Divide particles into two initial clusters by hemisphere.
78074       DO 270 I=N+1,N+NP
78075         PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
78076         IS=1
78077         IF(PSAX.LT.0D0) IS=2
78078         K(I,3)=IS
78079         DO 260 J=1,4
78080           PS(IS,J)=PS(IS,J)+P(I,J)
78081   260   CONTINUE
78082   270 CONTINUE
78083       PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
78084      &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
78085  
78086 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
78087   280 PMD=0D0
78088       IM=0
78089       DO 290 J=1,4
78090         PS(3,J)=PS(1,J)-PS(2,J)
78091   290 CONTINUE
78092       DO 300 I=N+1,N+NP
78093         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)
78094         IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
78095         IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
78096         IF(PMDI.LT.PMD) THEN
78097           PMD=PMDI
78098           IM=I
78099         ENDIF
78100   300 CONTINUE
78101  
78102 C...Loop back if significant reduction in sum of m^2.
78103       IF(PMD.LT.-PARU(48)*PMS) THEN
78104         PMS=PMS+PMD
78105         IS=K(IM,3)
78106         DO 310 J=1,4
78107           PS(IS,J)=PS(IS,J)-P(IM,J)
78108           PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
78109   310   CONTINUE
78110         K(IM,3)=3-IS
78111         GOTO 280
78112       ENDIF
78113  
78114 C...Final masses and output.
78115       MSTU(61)=N+1
78116       MSTU(62)=NP
78117       PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
78118       PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
78119       PMH=MAX(PS(1,5),PS(2,5))
78120       PML=MIN(PS(1,5),PS(2,5))
78121  
78122       RETURN
78123       END
78124  
78125 C*********************************************************************
78126  
78127 C...PYFOWO
78128 C...Calculates the first few Fox-Wolfram moments.
78129  
78130       SUBROUTINE PYFOWO(H10,H20,H30,H40)
78131  
78132 C...Double precision and integer declarations.
78133       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78134       IMPLICIT INTEGER(I-N)
78135       INTEGER PYK,PYCHGE,PYCOMP
78136 C...Parameter statement to help give large particle numbers.
78137       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
78138      &KEXCIT=4000000,KDIMEN=5000000)
78139 C...Commonblocks.
78140       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78141       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78142       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78143       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
78144  
78145 C...Copy momenta for particles and calculate H0.
78146       NP=0
78147       H0=0D0
78148       HD=0D0
78149       DO 110 I=1,N
78150         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
78151         IF(MSTU(41).GE.2) THEN
78152           KC=PYCOMP(K(I,2))
78153           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
78154      &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
78155      &    K(I,2).EQ.KSUSY1+39) GOTO 110
78156           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
78157      &    GOTO 110
78158         ENDIF
78159         IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
78160           CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
78161           H10=-1D0
78162           H20=-1D0
78163           H30=-1D0
78164           H40=-1D0
78165           RETURN
78166         ENDIF
78167         NP=NP+1
78168         DO 100 J=1,3
78169           P(N+NP,J)=P(I,J)
78170   100   CONTINUE
78171         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
78172         H0=H0+P(N+NP,4)
78173         HD=HD+P(N+NP,4)**2
78174   110 CONTINUE
78175       H0=H0**2
78176  
78177 C...Very low multiplicities (0 or 1) not considered.
78178       IF(NP.LE.1) THEN
78179         CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
78180         H10=-1D0
78181         H20=-1D0
78182         H30=-1D0
78183         H40=-1D0
78184         RETURN
78185       ENDIF
78186  
78187 C...Calculate H1 - H4.
78188       H10=0D0
78189       H20=0D0
78190       H30=0D0
78191       H40=0D0
78192       DO 130 I1=N+1,N+NP
78193         DO 120 I2=I1+1,N+NP
78194           CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
78195      &    (P(I1,4)*P(I2,4))
78196           H10=H10+P(I1,4)*P(I2,4)*CTHE
78197           H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
78198           H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
78199           H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
78200      &    0.375D0)
78201   120   CONTINUE
78202   130 CONTINUE
78203  
78204 C...Calculate H1/H0 - H4/H0. Output.
78205       MSTU(61)=N+1
78206       MSTU(62)=NP
78207       H10=(HD+2D0*H10)/H0
78208       H20=(HD+2D0*H20)/H0
78209       H30=(HD+2D0*H30)/H0
78210       H40=(HD+2D0*H40)/H0
78211  
78212       RETURN
78213       END
78214  
78215 C*********************************************************************
78216  
78217 C...PYTABU
78218 C...Evaluates various properties of an event, with statistics
78219 C...accumulated during the course of the run and
78220 C...printed at the end.
78221  
78222       SUBROUTINE PYTABU(MTABU)
78223  
78224 C...Double precision and integer declarations.
78225       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78226       IMPLICIT INTEGER(I-N)
78227       INTEGER PYK,PYCHGE,PYCOMP
78228 C...Parameter statement to help give large particle numbers.
78229       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
78230      &KEXCIT=4000000,KDIMEN=5000000)
78231 C...Commonblocks.
78232       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78233       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78234       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78235       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
78236       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
78237 C...Local arrays, character variables, saved variables and data.
78238       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
78239      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
78240      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
78241      &KFDM(8),KFDC(200,0:8),NPDC(200)
78242       SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
78243      &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
78244      &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
78245       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
78246       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
78247      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
78248      &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
78249      &NEVDC/0/,NKFDC/0/,NREDC/0/
78250  
78251 C...Reset statistics on initial parton state.
78252       IF(MTABU.EQ.10) THEN
78253         NEVIS=0
78254         NKFIS=0
78255  
78256 C...Identify and order flavour content of initial state.
78257       ELSEIF(MTABU.EQ.11) THEN
78258         NEVIS=NEVIS+1
78259         KFM1=2*IABS(MSTU(161))
78260         IF(MSTU(161).GT.0) KFM1=KFM1-1
78261         KFM2=2*IABS(MSTU(162))
78262         IF(MSTU(162).GT.0) KFM2=KFM2-1
78263         KFMN=MIN(KFM1,KFM2)
78264         KFMX=MAX(KFM1,KFM2)
78265         DO 100 I=1,NKFIS
78266           IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
78267             IKFIS=-I
78268             GOTO 110
78269           ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
78270      &      KFMX.LT.KFIS(I,2))) THEN
78271             IKFIS=I
78272             GOTO 110
78273           ENDIF
78274   100   CONTINUE
78275         IKFIS=NKFIS+1
78276   110   IF(IKFIS.LT.0) THEN
78277           IKFIS=-IKFIS
78278         ELSE
78279           IF(NKFIS.GE.100) RETURN
78280           DO 130 I=NKFIS,IKFIS,-1
78281             KFIS(I+1,1)=KFIS(I,1)
78282             KFIS(I+1,2)=KFIS(I,2)
78283             DO 120 J=0,10
78284               NPIS(I+1,J)=NPIS(I,J)
78285   120       CONTINUE
78286   130     CONTINUE
78287           NKFIS=NKFIS+1
78288           KFIS(IKFIS,1)=KFMN
78289           KFIS(IKFIS,2)=KFMX
78290           DO 140 J=0,10
78291             NPIS(IKFIS,J)=0
78292   140     CONTINUE
78293         ENDIF
78294         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
78295  
78296 C...Count number of partons in initial state.
78297         NP=0
78298         DO 160 I=1,N
78299           IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
78300           ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
78301           ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
78302      &      THEN
78303           ELSE
78304             IM=I
78305   150       IM=K(IM,3)
78306             IF(IM.LE.0.OR.IM.GT.N) THEN
78307               NP=NP+1
78308             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
78309               NP=NP+1
78310             ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
78311             ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
78312      &        .NE.0) THEN
78313             ELSE
78314               GOTO 150
78315             ENDIF
78316           ENDIF
78317   160   CONTINUE
78318         NPCO=MAX(NP,1)
78319         IF(NP.GE.6) NPCO=6
78320         IF(NP.GE.8) NPCO=7
78321         IF(NP.GE.11) NPCO=8
78322         IF(NP.GE.16) NPCO=9
78323         IF(NP.GE.26) NPCO=10
78324         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
78325         MSTU(62)=NP
78326  
78327 C...Write statistics on initial parton state.
78328       ELSEIF(MTABU.EQ.12) THEN
78329         FAC=1D0/MAX(1,NEVIS)
78330         WRITE(MSTU(11),5000) NEVIS
78331         DO 170 I=1,NKFIS
78332           KFMN=KFIS(I,1)
78333           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
78334           KFM1=(KFMN+1)/2
78335           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
78336           CALL PYNAME(KFM1,CHAU)
78337           CHIS(1)=CHAU(1:12)
78338           IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
78339           KFMX=KFIS(I,2)
78340           IF(KFIS(I,1).EQ.0) KFMX=0
78341           KFM2=(KFMX+1)/2
78342           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
78343           CALL PYNAME(KFM2,CHAU)
78344           CHIS(2)=CHAU(1:12)
78345           IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
78346           WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
78347      &    (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
78348   170   CONTINUE
78349  
78350 C...Copy statistics on initial parton state into /PYJETS/.
78351       ELSEIF(MTABU.EQ.13) THEN
78352         FAC=1D0/MAX(1,NEVIS)
78353         DO 190 I=1,NKFIS
78354           KFMN=KFIS(I,1)
78355           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
78356           KFM1=(KFMN+1)/2
78357           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
78358           KFMX=KFIS(I,2)
78359           IF(KFIS(I,1).EQ.0) KFMX=0
78360           KFM2=(KFMX+1)/2
78361           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
78362           K(I,1)=32
78363           K(I,2)=99
78364           K(I,3)=KFM1
78365           K(I,4)=KFM2
78366           K(I,5)=NPIS(I,0)
78367           DO 180 J=1,5
78368             P(I,J)=FAC*NPIS(I,J)
78369             V(I,J)=FAC*NPIS(I,J+5)
78370   180     CONTINUE
78371   190   CONTINUE
78372         N=NKFIS
78373         DO 200 J=1,5
78374           K(N+1,J)=0
78375           P(N+1,J)=0D0
78376           V(N+1,J)=0D0
78377   200   CONTINUE
78378         K(N+1,1)=32
78379         K(N+1,2)=99
78380         K(N+1,5)=NEVIS
78381         MSTU(3)=1
78382  
78383 C...Reset statistics on number of particles/partons.
78384       ELSEIF(MTABU.EQ.20) THEN
78385         NEVFS=0
78386         NPRFS=0
78387         NFIFS=0
78388         NCHFS=0
78389         NKFFS=0
78390  
78391 C...Identify whether particle/parton is primary or not.
78392       ELSEIF(MTABU.EQ.21) THEN
78393         NEVFS=NEVFS+1
78394         MSTU(62)=0
78395         DO 260 I=1,N
78396           IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
78397           MSTU(62)=MSTU(62)+1
78398           KC=PYCOMP(K(I,2))
78399           MPRI=0
78400           IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
78401             MPRI=1
78402           ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
78403             MPRI=1
78404           ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
78405             MPRI=1
78406           ELSEIF(KC.EQ.0) THEN
78407           ELSEIF(K(K(I,3),1).EQ.13) THEN
78408             IM=K(K(I,3),3)
78409             IF(IM.LE.0.OR.IM.GT.N) THEN
78410               MPRI=1
78411             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
78412               MPRI=1
78413             ENDIF
78414           ELSEIF(KCHG(KC,2).EQ.0) THEN
78415             KCM=PYCOMP(K(K(I,3),2))
78416             IF(KCM.NE.0) THEN
78417               IF(KCHG(KCM,2).NE.0) MPRI=1
78418             ENDIF
78419           ENDIF
78420           IF(KC.NE.0.AND.MPRI.EQ.1) THEN
78421             IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
78422           ENDIF
78423           IF(K(I,1).LE.10) THEN
78424             NFIFS=NFIFS+1
78425             IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
78426           ENDIF
78427  
78428 C...Fill statistics on number of particles/partons in event.
78429           KFA=IABS(K(I,2))
78430           KFS=3-ISIGN(1,K(I,2))-MPRI
78431           DO 210 IP=1,NKFFS
78432             IF(KFA.EQ.KFFS(IP)) THEN
78433               IKFFS=-IP
78434               GOTO 220
78435             ELSEIF(KFA.LT.KFFS(IP)) THEN
78436               IKFFS=IP
78437               GOTO 220
78438             ENDIF
78439   210     CONTINUE
78440           IKFFS=NKFFS+1
78441   220     IF(IKFFS.LT.0) THEN
78442             IKFFS=-IKFFS
78443           ELSE
78444             IF(NKFFS.GE.400) RETURN
78445             DO 240 IP=NKFFS,IKFFS,-1
78446               KFFS(IP+1)=KFFS(IP)
78447               DO 230 J=1,4
78448                 NPFS(IP+1,J)=NPFS(IP,J)
78449   230         CONTINUE
78450   240       CONTINUE
78451             NKFFS=NKFFS+1
78452             KFFS(IKFFS)=KFA
78453             DO 250 J=1,4
78454               NPFS(IKFFS,J)=0
78455   250       CONTINUE
78456           ENDIF
78457           NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
78458   260   CONTINUE
78459  
78460 C...Write statistics on particle/parton composition of events.
78461       ELSEIF(MTABU.EQ.22) THEN
78462         FAC=1D0/MAX(1,NEVFS)
78463         WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
78464         DO 270 I=1,NKFFS
78465           CALL PYNAME(KFFS(I),CHAU)
78466           KC=PYCOMP(KFFS(I))
78467           MDCYF=0
78468           IF(KC.NE.0) MDCYF=MDCY(KC,1)
78469           WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
78470      &    FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
78471   270   CONTINUE
78472  
78473 C...Copy particle/parton composition information into /PYJETS/.
78474       ELSEIF(MTABU.EQ.23) THEN
78475         FAC=1D0/MAX(1,NEVFS)
78476         DO 290 I=1,NKFFS
78477           K(I,1)=32
78478           K(I,2)=99
78479           K(I,3)=KFFS(I)
78480           K(I,4)=0
78481           K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
78482           DO 280 J=1,4
78483             P(I,J)=FAC*NPFS(I,J)
78484             V(I,J)=0D0
78485   280     CONTINUE
78486           P(I,5)=FAC*K(I,5)
78487           V(I,5)=0D0
78488   290   CONTINUE
78489         N=NKFFS
78490         DO 300 J=1,5
78491           K(N+1,J)=0
78492           P(N+1,J)=0D0
78493           V(N+1,J)=0D0
78494   300   CONTINUE
78495         K(N+1,1)=32
78496         K(N+1,2)=99
78497         K(N+1,5)=NEVFS
78498         P(N+1,1)=FAC*NPRFS
78499         P(N+1,2)=FAC*NFIFS
78500         P(N+1,3)=FAC*NCHFS
78501         MSTU(3)=1
78502  
78503 C...Reset factorial moments statistics.
78504       ELSEIF(MTABU.EQ.30) THEN
78505         NEVFM=0
78506         NMUFM=0
78507         DO 330 IM=1,3
78508           DO 320 IB=1,10
78509             DO 310 IP=1,4
78510               FM1FM(IM,IB,IP)=0D0
78511               FM2FM(IM,IB,IP)=0D0
78512   310       CONTINUE
78513   320     CONTINUE
78514   330   CONTINUE
78515  
78516 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
78517       ELSEIF(MTABU.EQ.31) THEN
78518         NEVFM=NEVFM+1
78519         NLOW=N+MSTU(3)
78520         NUPP=NLOW
78521         DO 410 I=1,N
78522           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
78523           IF(MSTU(41).GE.2) THEN
78524             KC=PYCOMP(K(I,2))
78525             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
78526      &      KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
78527      &      K(I,2).EQ.KSUSY1+39) GOTO 410
78528             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
78529      &      PYCHGE(K(I,2)).EQ.0) GOTO 410
78530           ENDIF
78531           PMR=0D0
78532           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
78533           IF(MSTU(42).GE.2) PMR=P(I,5)
78534           PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
78535           YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
78536      &    1D20)),P(I,3))
78537           IF(ABS(YETA).GT.PARU(57)) GOTO 410
78538           PHI=PYANGL(P(I,1),P(I,2))
78539           IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
78540           IYETA=MAX(0,MIN(511,IYETA))
78541           IPHI=512D0*(PHI+PARU(1))/PARU(2)
78542           IPHI=MAX(0,MIN(511,IPHI))
78543           IYEP=0
78544           DO 340 IB=0,9
78545             IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
78546   340     CONTINUE
78547  
78548 C...Order particles in (pseudo)rapidity and/or azimuth.
78549           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
78550             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
78551             RETURN
78552           ENDIF
78553           NUPP=NUPP+1
78554           IF(NUPP.EQ.NLOW+1) THEN
78555             K(NUPP,1)=IYETA
78556             K(NUPP,2)=IPHI
78557             K(NUPP,3)=IYEP
78558           ELSE
78559             DO 350 I1=NUPP-1,NLOW+1,-1
78560               IF(IYETA.GE.K(I1,1)) GOTO 360
78561               K(I1+1,1)=K(I1,1)
78562   350       CONTINUE
78563   360       K(I1+1,1)=IYETA
78564             DO 370 I1=NUPP-1,NLOW+1,-1
78565               IF(IPHI.GE.K(I1,2)) GOTO 380
78566               K(I1+1,2)=K(I1,2)
78567   370       CONTINUE
78568   380       K(I1+1,2)=IPHI
78569             DO 390 I1=NUPP-1,NLOW+1,-1
78570               IF(IYEP.GE.K(I1,3)) GOTO 400
78571               K(I1+1,3)=K(I1,3)
78572   390       CONTINUE
78573   400       K(I1+1,3)=IYEP
78574           ENDIF
78575   410   CONTINUE
78576         K(NUPP+1,1)=2**10
78577         K(NUPP+1,2)=2**10
78578         K(NUPP+1,3)=4**10
78579  
78580 C...Calculate sum of factorial moments in event.
78581         DO 480 IM=1,3
78582           DO 430 IB=1,10
78583             DO 420 IP=1,4
78584               FEVFM(IB,IP)=0D0
78585   420       CONTINUE
78586   430     CONTINUE
78587           DO 450 IB=1,10
78588             IF(IM.LE.2) IBIN=2**(10-IB)
78589             IF(IM.EQ.3) IBIN=4**(10-IB)
78590             IAGR=K(NLOW+1,IM)/IBIN
78591             NAGR=1
78592             DO 440 I=NLOW+2,NUPP+1
78593               ICUT=K(I,IM)/IBIN
78594               IF(ICUT.EQ.IAGR) THEN
78595                 NAGR=NAGR+1
78596               ELSE
78597                 IF(NAGR.EQ.1) THEN
78598                 ELSEIF(NAGR.EQ.2) THEN
78599                   FEVFM(IB,1)=FEVFM(IB,1)+2D0
78600                 ELSEIF(NAGR.EQ.3) THEN
78601                   FEVFM(IB,1)=FEVFM(IB,1)+6D0
78602                   FEVFM(IB,2)=FEVFM(IB,2)+6D0
78603                 ELSEIF(NAGR.EQ.4) THEN
78604                   FEVFM(IB,1)=FEVFM(IB,1)+12D0
78605                   FEVFM(IB,2)=FEVFM(IB,2)+24D0
78606                   FEVFM(IB,3)=FEVFM(IB,3)+24D0
78607                 ELSE
78608                   FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
78609                   FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
78610                   FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
78611      &            (NAGR-3D0)
78612                   FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
78613      &            (NAGR-3D0)*(NAGR-4D0)
78614                 ENDIF
78615                 IAGR=ICUT
78616                 NAGR=1
78617               ENDIF
78618   440       CONTINUE
78619   450     CONTINUE
78620  
78621 C...Add results to total statistics.
78622           DO 470 IB=10,1,-1
78623             DO 460 IP=1,4
78624               IF(FEVFM(1,IP).LT.0.5D0) THEN
78625                 FEVFM(IB,IP)=0D0
78626               ELSEIF(IM.LE.2) THEN
78627                 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
78628               ELSE
78629                 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
78630               ENDIF
78631               FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
78632               FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
78633   460       CONTINUE
78634   470     CONTINUE
78635   480   CONTINUE
78636         NMUFM=NMUFM+(NUPP-NLOW)
78637         MSTU(62)=NUPP-NLOW
78638  
78639 C...Write accumulated statistics on factorial moments.
78640       ELSEIF(MTABU.EQ.32) THEN
78641         FAC=1D0/MAX(1,NEVFM)
78642         IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
78643         IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
78644         IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y  '
78645         DO 510 IM=1,3
78646           WRITE(MSTU(11),5500)
78647           DO 500 IB=1,10
78648             BYETA=2D0*PARU(57)
78649             IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
78650             BPHI=PARU(2)
78651             IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
78652             IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
78653             IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
78654             DO 490 IP=1,4
78655               FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
78656               FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
78657      &        FMOMA(IP)**2)))
78658   490       CONTINUE
78659             WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
78660      &      IP=1,4)
78661   500     CONTINUE
78662   510   CONTINUE
78663  
78664 C...Copy statistics on factorial moments into /PYJETS/.
78665       ELSEIF(MTABU.EQ.33) THEN
78666         FAC=1D0/MAX(1,NEVFM)
78667         DO 540 IM=1,3
78668           DO 530 IB=1,10
78669             I=10*(IM-1)+IB
78670             K(I,1)=32
78671             K(I,2)=99
78672             K(I,3)=1
78673             IF(IM.NE.2) K(I,3)=2**(IB-1)
78674             K(I,4)=1
78675             IF(IM.NE.1) K(I,4)=2**(IB-1)
78676             K(I,5)=0
78677             P(I,1)=2D0*PARU(57)/K(I,3)
78678             V(I,1)=PARU(2)/K(I,4)
78679             DO 520 IP=1,4
78680               P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
78681               V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
78682      &        P(I,IP+1)**2)))
78683   520       CONTINUE
78684   530     CONTINUE
78685   540   CONTINUE
78686         N=30
78687         DO 550 J=1,5
78688           K(N+1,J)=0
78689           P(N+1,J)=0D0
78690           V(N+1,J)=0D0
78691   550   CONTINUE
78692         K(N+1,1)=32
78693         K(N+1,2)=99
78694         K(N+1,5)=NEVFM
78695         MSTU(3)=1
78696  
78697 C...Reset statistics on Energy-Energy Correlation.
78698       ELSEIF(MTABU.EQ.40) THEN
78699         NEVEE=0
78700         DO 560 J=1,25
78701           FE1EC(J)=0D0
78702           FE2EC(J)=0D0
78703           FE1EC(51-J)=0D0
78704           FE2EC(51-J)=0D0
78705           FE1EA(J)=0D0
78706           FE2EA(J)=0D0
78707   560   CONTINUE
78708  
78709 C...Find particles to include, with proper assumed mass.
78710       ELSEIF(MTABU.EQ.41) THEN
78711         NEVEE=NEVEE+1
78712         NLOW=N+MSTU(3)
78713         NUPP=NLOW
78714         ECM=0D0
78715         DO 570 I=1,N
78716           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
78717           IF(MSTU(41).GE.2) THEN
78718             KC=PYCOMP(K(I,2))
78719             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
78720      &      KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
78721      &      K(I,2).EQ.KSUSY1+39) GOTO 570
78722             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
78723      &      PYCHGE(K(I,2)).EQ.0) GOTO 570
78724           ENDIF
78725           PMR=0D0
78726           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
78727           IF(MSTU(42).GE.2) PMR=P(I,5)
78728           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
78729             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
78730             RETURN
78731           ENDIF
78732           NUPP=NUPP+1
78733           P(NUPP,1)=P(I,1)
78734           P(NUPP,2)=P(I,2)
78735           P(NUPP,3)=P(I,3)
78736           P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
78737           P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
78738           ECM=ECM+P(NUPP,4)
78739   570   CONTINUE
78740         IF(NUPP.EQ.NLOW) RETURN
78741  
78742 C...Analyze Energy-Energy Correlation in event.
78743         FAC=(2D0/ECM**2)*50D0/PARU(1)
78744         DO 580 J=1,50
78745           FEVEE(J)=0D0
78746   580   CONTINUE
78747         DO 600 I1=NLOW+2,NUPP
78748           DO 590 I2=NLOW+1,I1-1
78749             CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
78750      &      (P(I1,5)*P(I2,5))
78751             THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
78752             ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
78753             FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
78754   590     CONTINUE
78755   600   CONTINUE
78756         DO 610 J=1,25
78757           FE1EC(J)=FE1EC(J)+FEVEE(J)
78758           FE2EC(J)=FE2EC(J)+FEVEE(J)**2
78759           FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
78760           FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
78761           FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
78762           FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
78763   610   CONTINUE
78764         MSTU(62)=NUPP-NLOW
78765  
78766 C...Write statistics on Energy-Energy Correlation.
78767       ELSEIF(MTABU.EQ.42) THEN
78768         FAC=1D0/MAX(1,NEVEE)
78769         WRITE(MSTU(11),5700) NEVEE
78770         DO 620 J=1,25
78771           FEEC1=FAC*FE1EC(J)
78772           FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
78773           FEEC2=FAC*FE1EC(51-J)
78774           FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
78775           FEECA=FAC*FE1EA(J)
78776           FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
78777           WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
78778      &    FEEC2,FEES2,FEECA,FEESA
78779   620   CONTINUE
78780  
78781 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
78782       ELSEIF(MTABU.EQ.43) THEN
78783         FAC=1D0/MAX(1,NEVEE)
78784         DO 630 I=1,25
78785           K(I,1)=32
78786           K(I,2)=99
78787           K(I,3)=0
78788           K(I,4)=0
78789           K(I,5)=0
78790           P(I,1)=FAC*FE1EC(I)
78791           V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
78792           P(I,2)=FAC*FE1EC(51-I)
78793           V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
78794           P(I,3)=FAC*FE1EA(I)
78795           V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
78796           P(I,4)=PARU(1)*(I-1)/50D0
78797           P(I,5)=PARU(1)*I/50D0
78798           V(I,4)=3.6D0*(I-1)
78799           V(I,5)=3.6D0*I
78800   630   CONTINUE
78801         N=25
78802         DO 640 J=1,5
78803           K(N+1,J)=0
78804           P(N+1,J)=0D0
78805           V(N+1,J)=0D0
78806   640   CONTINUE
78807         K(N+1,1)=32
78808         K(N+1,2)=99
78809         K(N+1,5)=NEVEE
78810         MSTU(3)=1
78811  
78812 C...Reset statistics on decay channels.
78813       ELSEIF(MTABU.EQ.50) THEN
78814         NEVDC=0
78815         NKFDC=0
78816         NREDC=0
78817  
78818 C...Identify and order flavour content of final state.
78819       ELSEIF(MTABU.EQ.51) THEN
78820         NEVDC=NEVDC+1
78821         NDS=0
78822         DO 670 I=1,N
78823           IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
78824           NDS=NDS+1
78825           IF(NDS.GT.8) THEN
78826             NREDC=NREDC+1
78827             RETURN
78828           ENDIF
78829           KFM=2*IABS(K(I,2))
78830           IF(K(I,2).LT.0) KFM=KFM-1
78831           DO 650 IDS=NDS-1,1,-1
78832             IIN=IDS+1
78833             IF(KFM.LT.KFDM(IDS)) GOTO 660
78834             KFDM(IDS+1)=KFDM(IDS)
78835   650     CONTINUE
78836           IIN=1
78837   660     KFDM(IIN)=KFM
78838   670   CONTINUE
78839  
78840 C...Find whether old or new final state.
78841         DO 690 IDC=1,NKFDC
78842           IF(NDS.LT.KFDC(IDC,0)) THEN
78843             IKFDC=IDC
78844             GOTO 700
78845           ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
78846             DO 680 I=1,NDS
78847               IF(KFDM(I).LT.KFDC(IDC,I)) THEN
78848                 IKFDC=IDC
78849                 GOTO 700
78850               ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
78851                 GOTO 690
78852               ENDIF
78853   680       CONTINUE
78854             IKFDC=-IDC
78855             GOTO 700
78856           ENDIF
78857   690   CONTINUE
78858         IKFDC=NKFDC+1
78859   700   IF(IKFDC.LT.0) THEN
78860           IKFDC=-IKFDC
78861         ELSEIF(NKFDC.GE.200) THEN
78862           NREDC=NREDC+1
78863           RETURN
78864         ELSE
78865           DO 720 IDC=NKFDC,IKFDC,-1
78866             NPDC(IDC+1)=NPDC(IDC)
78867             DO 710 I=0,8
78868               KFDC(IDC+1,I)=KFDC(IDC,I)
78869   710       CONTINUE
78870   720     CONTINUE
78871           NKFDC=NKFDC+1
78872           KFDC(IKFDC,0)=NDS
78873           DO 730 I=1,NDS
78874             KFDC(IKFDC,I)=KFDM(I)
78875   730     CONTINUE
78876           NPDC(IKFDC)=0
78877         ENDIF
78878         NPDC(IKFDC)=NPDC(IKFDC)+1
78879  
78880 C...Write statistics on decay channels.
78881       ELSEIF(MTABU.EQ.52) THEN
78882         FAC=1D0/MAX(1,NEVDC)
78883         WRITE(MSTU(11),5900) NEVDC
78884         DO 750 IDC=1,NKFDC
78885           DO 740 I=1,KFDC(IDC,0)
78886             KFM=KFDC(IDC,I)
78887             KF=(KFM+1)/2
78888             IF(2*KF.NE.KFM) KF=-KF
78889             CALL PYNAME(KF,CHAU)
78890             CHDC(I)=CHAU(1:12)
78891             IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
78892   740     CONTINUE
78893           WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
78894   750   CONTINUE
78895         IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
78896  
78897 C...Copy statistics on decay channels into /PYJETS/.
78898       ELSEIF(MTABU.EQ.53) THEN
78899         FAC=1D0/MAX(1,NEVDC)
78900         DO 780 IDC=1,NKFDC
78901           K(IDC,1)=32
78902           K(IDC,2)=99
78903           K(IDC,3)=0
78904           K(IDC,4)=0
78905           K(IDC,5)=KFDC(IDC,0)
78906           DO 760 J=1,5
78907             P(IDC,J)=0D0
78908             V(IDC,J)=0D0
78909   760     CONTINUE
78910           DO 770 I=1,KFDC(IDC,0)
78911             KFM=KFDC(IDC,I)
78912             KF=(KFM+1)/2
78913             IF(2*KF.NE.KFM) KF=-KF
78914             IF(I.LE.5) P(IDC,I)=KF
78915             IF(I.GE.6) V(IDC,I-5)=KF
78916   770     CONTINUE
78917           V(IDC,5)=FAC*NPDC(IDC)
78918   780   CONTINUE
78919         N=NKFDC
78920         DO 790 J=1,5
78921           K(N+1,J)=0
78922           P(N+1,J)=0D0
78923           V(N+1,J)=0D0
78924   790   CONTINUE
78925         K(N+1,1)=32
78926         K(N+1,2)=99
78927         K(N+1,5)=NEVDC
78928         V(N+1,5)=FAC*NREDC
78929         MSTU(3)=1
78930       ENDIF
78931  
78932 C...Format statements for output on unit MSTU(11) (default 6).
78933  5000 FORMAT(///20X,'Event statistics - initial state'/
78934      &20X,'based on an analysis of ',I6,' events'//
78935      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
78936      &'according to fragmenting system multiplicity'/
78937      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
78938      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
78939  5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
78940  5200 FORMAT(///20X,'Event statistics - final state'/
78941      &20X,'based on an analysis of ',I7,' events'//
78942      &5X,'Mean primary multiplicity =',F10.4/
78943      &5X,'Mean final   multiplicity =',F10.4/
78944      &5X,'Mean charged multiplicity =',F10.4//
78945      &5X,'Number of particles produced per event (directly and via ',
78946      &'decays/branchings)'/
78947      &8X,'KF    Particle/jet  MDCY',10X,'Particles',13X,'Antiparticles',
78948      &8X,'Total'/35X,'prim        seco        prim        seco'/)
78949  5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
78950  5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
78951      &20X,'based on an analysis of ',I6,' events'//
78952      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
78953      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
78954  5500 FORMAT(10X)
78955  5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
78956  5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
78957      &20X,'based on an analysis of ',I6,' events'//
78958      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
78959      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
78960  5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
78961  5900 FORMAT(///20X,'Decay channel analysis - final state'/
78962      &20X,'based on an analysis of ',I6,' events'//
78963      &2X,'Probability',10X,'Complete final state'/)
78964  6000 FORMAT(2X,F9.5,5X,8(A12,1X))
78965  6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
78966      &'or table overflow)')
78967  
78968       RETURN
78969       END
78970  
78971 C*********************************************************************
78972  
78973 C...PYEEVT
78974 C...Handles the generation of an e+e- annihilation jet event.
78975  
78976       SUBROUTINE PYEEVT(KFL,ECM)
78977  
78978 C...Double precision and integer declarations.
78979       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78980       IMPLICIT INTEGER(I-N)
78981       INTEGER PYK,PYCHGE,PYCOMP
78982 C...Commonblocks.
78983       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78984       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78985       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78986       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
78987  
78988 C...Check input parameters.
78989       IF(MSTU(12).NE.12345) CALL PYLIST(0)
78990       IF(KFL.LT.0.OR.KFL.GT.8) THEN
78991         CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
78992         IF(MSTU(21).GE.1) RETURN
78993       ENDIF
78994       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
78995       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
78996       IF(ECM.LT.ECMMIN) THEN
78997         CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
78998         IF(MSTU(21).GE.1) RETURN
78999       ENDIF
79000  
79001 C...Check consistency of MSTJ options set.
79002       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
79003         CALL PYERRM(6,
79004      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
79005         MSTJ(110)=1
79006       ENDIF
79007       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
79008         CALL PYERRM(6,
79009      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
79010         MSTJ(111)=0
79011       ENDIF
79012  
79013 C...Initialize alpha_strong and total cross-section.
79014       MSTU(111)=MSTJ(108)
79015       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
79016      &MSTU(111)=1
79017       PARU(112)=PARJ(121)
79018       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
79019       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
79020      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
79021      &XTOT)
79022       IF(MSTJ(116).GE.3) MSTJ(116)=1
79023       PARJ(171)=0D0
79024  
79025 C...Add initial e+e- to event record (documentation only).
79026       NTRY=0
79027   100 NTRY=NTRY+1
79028       IF(NTRY.GT.100) THEN
79029         CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
79030         RETURN
79031       ENDIF
79032       MSTU(24)=0
79033       NC=0
79034       IF(MSTJ(115).GE.2) THEN
79035         NC=NC+2
79036         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
79037         K(NC-1,1)=21
79038         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
79039         K(NC,1)=21
79040       ENDIF
79041  
79042 C...Radiative photon (in initial state).
79043       MK=0
79044       ECMC=ECM
79045       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
79046      &THEK,PHIK,ALPK)
79047       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
79048       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
79049         NC=NC+1
79050         CALL PY1ENT(NC,22,PAK,THEK,PHIK)
79051         K(NC,3)=MIN(MSTJ(115)/2,1)
79052       ENDIF
79053  
79054 C...Virtual exchange boson (gamma or Z0).
79055       IF(MSTJ(115).GE.3) THEN
79056         NC=NC+1
79057         KF=22
79058         IF(MSTJ(102).EQ.2) KF=23
79059         MSTU10=MSTU(10)
79060         MSTU(10)=1
79061         P(NC,5)=ECMC
79062         CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
79063         K(NC,1)=21
79064         K(NC,3)=1
79065         MSTU(10)=MSTU10
79066       ENDIF
79067  
79068 C...Choice of flavour and jet configuration.
79069       CALL PYXKFL(KFL,ECM,ECMC,KFLC)
79070       IF(KFLC.EQ.0) GOTO 100
79071       CALL PYXJET(ECMC,NJET,CUT)
79072       KFLN=21
79073       IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
79074      &X12,X14)
79075       IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
79076       IF(NJET.EQ.2) MSTJ(120)=1
79077  
79078 C...Fill jet configuration and origin.
79079       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
79080       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
79081      &ECMC)
79082       IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
79083       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
79084      &-KFLC,ECMC,X1,X2,X4,X12,X14)
79085       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
79086      &-KFLC,ECMC,X1,X2,X4,X12,X14)
79087       IF(MSTU(24).NE.0) GOTO 100
79088       DO 110 IP=NC+1,N
79089         K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
79090   110 CONTINUE
79091  
79092 C...Angular orientation according to matrix element.
79093       IF(MSTJ(106).EQ.1) THEN
79094         CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
79095         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
79096         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
79097       ENDIF
79098  
79099 C...Rotation and boost from radiative photon.
79100       IF(MK.EQ.1) THEN
79101         DBEK=-PAK/(ECM-PAK)
79102         NMIN=NC+1-MSTJ(115)/3
79103         CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
79104         CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
79105         CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
79106       ENDIF
79107  
79108 C...Generate parton shower. Rearrange along strings and check.
79109       IF(MSTJ(101).EQ.5) THEN
79110         CALL PYSHOW(N-1,N,ECMC)
79111         MSTJ14=MSTJ(14)
79112         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
79113         IF(MSTJ(105).GE.0) MSTU(28)=0
79114         CALL PYPREP(0)
79115         MSTJ(14)=MSTJ14
79116         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
79117       ENDIF
79118  
79119 C...Fragmentation/decay generation. Information for PYTABU.
79120       IF(MSTJ(105).EQ.1) CALL PYEXEC
79121       MSTU(161)=KFLC
79122       MSTU(162)=-KFLC
79123  
79124       RETURN
79125       END
79126  
79127 C*********************************************************************
79128  
79129 C...PYXTEE
79130 C...Calculates total cross-section, including initial state
79131 C...radiation effects.
79132  
79133       SUBROUTINE PYXTEE(KFL,ECM,XTOT)
79134  
79135 C...Double precision and integer declarations.
79136       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79137       IMPLICIT INTEGER(I-N)
79138       INTEGER PYK,PYCHGE,PYCOMP
79139 C...Commonblocks.
79140       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79141       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79142       SAVE /PYDAT1/,/PYDAT2/
79143  
79144 C...Status, (optimized) Q^2 scale, alpha_strong.
79145       PARJ(151)=ECM
79146       MSTJ(119)=10*MSTJ(102)+KFL
79147       IF(MSTJ(111).EQ.0) THEN
79148         Q2R=ECM**2
79149       ELSEIF(MSTU(111).EQ.0) THEN
79150         PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
79151      &  ((33D0-2D0*MSTU(112))*PARU(111)))))
79152         Q2R=PARJ(168)*ECM**2
79153       ELSE
79154         PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
79155      &  (2D0*PARU(112)/ECM)**2))
79156         Q2R=PARJ(168)*ECM**2
79157       ENDIF
79158       ALSPI=PYALPS(Q2R)/PARU(1)
79159  
79160 C...QCD corrections factor in R.
79161       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
79162         RQCD=1D0
79163       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
79164         RQCD=1D0+ALSPI
79165       ELSEIF(MSTJ(109).EQ.0) THEN
79166         RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
79167         IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
79168      &  LOG(PARJ(168))*ALSPI**2)
79169       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
79170         RQCD=1D0+(3D0/4D0)*ALSPI
79171       ELSE
79172         RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
79173       ENDIF
79174  
79175 C...Calculate Z0 width if default value not acceptable.
79176       IF(MSTJ(102).GE.3) THEN
79177         RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
79178      &  (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
79179         DO 100 KFLC=5,6
79180           VQ=1D0
79181           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
79182      &    (2D0*PYMASS(KFLC)/ ECM)**2))
79183           IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
79184           IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
79185           RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
79186   100   CONTINUE
79187         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
79188      &  (1D0-PARU(102)))
79189       ENDIF
79190  
79191 C...Calculate propagator and related constants for QFD case.
79192       POLL=1D0-PARJ(131)*PARJ(132)
79193       IF(MSTJ(102).GE.2) THEN
79194         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
79195         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
79196         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
79197         VE=4D0*PARU(102)-1D0
79198         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
79199         SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
79200         HF1I=SFI*SF1I
79201         HF1W=SFW*SF1W
79202       ENDIF
79203  
79204 C...Loop over different flavours: charge, velocity.
79205       RTOT=0D0
79206       RQQ=0D0
79207       RQV=0D0
79208       RVA=0D0
79209       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
79210         IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
79211         MSTJ(93)=1
79212         PMQ=PYMASS(KFLC)
79213         IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
79214         QF=KCHG(KFLC,1)/3D0
79215         VQ=1D0
79216         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
79217  
79218 C...Calculate R and sum of charges for QED or QFD case.
79219         RQQ=RQQ+3D0*QF**2*POLL
79220         IF(MSTJ(102).LE.1) THEN
79221           RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
79222         ELSE
79223           VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
79224           RQV=RQV-6D0*QF*VF*SF1I
79225           RVA=RVA+3D0*(VF**2+1D0)*SF1W
79226           RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
79227      &    2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
79228         ENDIF
79229   110 CONTINUE
79230       RSUM=RQQ
79231       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
79232  
79233 C...Calculate cross-section, including QCD corrections.
79234       PARJ(141)=RQQ
79235       PARJ(142)=RTOT
79236       PARJ(143)=RTOT*RQCD
79237       PARJ(144)=PARJ(143)
79238       PARJ(145)=PARJ(141)*86.8D0/ECM**2
79239       PARJ(146)=PARJ(142)*86.8D0/ECM**2
79240       PARJ(147)=PARJ(143)*86.8D0/ECM**2
79241       PARJ(148)=PARJ(147)
79242       PARJ(157)=RSUM*RQCD
79243       PARJ(158)=0D0
79244       PARJ(159)=0D0
79245       XTOT=PARJ(147)
79246       IF(MSTJ(107).LE.0) RETURN
79247  
79248 C...Virtual cross-section.
79249       XKL=PARJ(135)
79250       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
79251       ALE=2D0*LOG(ECM/PYMASS(11))-1D0
79252       SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
79253      &1.526D0*LOG(ECM**2/0.932D0)
79254  
79255 C...Soft and hard radiative cross-section in QED case.
79256       IF(MSTJ(102).LE.1) THEN
79257         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
79258         SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
79259         SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
79260  
79261 C...Soft and hard radiative cross-section in QFD case.
79262       ELSE
79263         SZM=1D0-(PARJ(123)/ECM)**2
79264         SZW=PARJ(123)*PARJ(124)/ECM**2
79265         PARJ(161)=-RQQ/RSUM
79266         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
79267         PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
79268         PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
79269      &  4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
79270         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
79271      &  RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
79272         SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
79273      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
79274      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
79275         SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
79276      &  (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
79277      &  LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
79278      &  PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
79279       ENDIF
79280  
79281 C...Total cross-section and fraction of hard photon events.
79282       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
79283       PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
79284       PARJ(144)=PARJ(157)
79285       PARJ(148)=PARJ(144)*86.8D0/ECM**2
79286       XTOT=PARJ(148)
79287  
79288       RETURN
79289       END
79290  
79291 C*********************************************************************
79292  
79293 C...PYRADK
79294 C...Generates initial state photon radiation.
79295  
79296       SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
79297  
79298 C...Double precision and integer declarations.
79299       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79300       IMPLICIT INTEGER(I-N)
79301       INTEGER PYK,PYCHGE,PYCOMP
79302 C...Commonblocks.
79303       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79304       SAVE /PYDAT1/
79305  
79306 C...Function: cumulative hard photon spectrum in QFD case.
79307       FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
79308      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
79309  
79310 C...Determine whether radiative photon or not.
79311       MK=0
79312       PAK=0D0
79313       IF(PARJ(160).LT.PYR(0)) RETURN
79314       MK=1
79315  
79316 C...Photon energy range. Find photon momentum in QED case.
79317       XKL=PARJ(135)
79318       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
79319       IF(MSTJ(102).LE.1) THEN
79320   100   XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
79321         IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
79322  
79323 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
79324       ELSE
79325         SZM=1D0-(PARJ(123)/ECM)**2
79326         SZW=PARJ(123)*PARJ(124)/ECM**2
79327         FXKL=FXK(XKL)
79328         FXKU=FXK(XKU)
79329         FXKD=1D-4*(FXKU-FXKL)
79330         FXKR=FXKL+PYR(0)*(FXKU-FXKL)
79331         NXK=0
79332   110   NXK=NXK+1
79333         XK=0.5D0*(XKL+XKU)
79334         FXKV=FXK(XK)
79335         IF(FXKV.GT.FXKR) THEN
79336           XKU=XK
79337           FXKU=FXKV
79338         ELSE
79339           XKL=XK
79340           FXKL=FXKV
79341         ENDIF
79342         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
79343         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
79344       ENDIF
79345       PAK=0.5D0*ECM*XK
79346  
79347 C...Photon polar and azimuthal angle.
79348       PME=2D0*(PYMASS(11)/ECM)**2
79349   120 CTHM=PME*(2D0/PME)**PYR(0)
79350       IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
79351      &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
79352       CTHE=1D0-CTHM
79353       IF(PYR(0).GT.0.5D0) CTHE=-CTHE
79354       STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
79355       THEK=PYANGL(CTHE,STHE)
79356       PHIK=PARU(2)*PYR(0)
79357  
79358 C...Rotation angle for hadronic system.
79359       SGN=1D0
79360       IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
79361      &PYR(0)) SGN=-1D0
79362       ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
79363      &(2D0-XK*(1D0-SGN*CTHE)))
79364  
79365       RETURN
79366       END
79367  
79368 C*********************************************************************
79369  
79370 C...PYXKFL
79371 C...Selects flavour for produced qqbar pair.
79372  
79373       SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
79374  
79375 C...Double precision and integer declarations.
79376       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79377       IMPLICIT INTEGER(I-N)
79378       INTEGER PYK,PYCHGE,PYCOMP
79379 C...Commonblocks.
79380       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79381       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79382       SAVE /PYDAT1/,/PYDAT2/
79383  
79384 C...Calculate maximum weight in QED or QFD case.
79385       IF(MSTJ(102).LE.1) THEN
79386         RFMAX=4D0/9D0
79387       ELSE
79388         POLL=1D0-PARJ(131)*PARJ(132)
79389         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
79390         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
79391         SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
79392         VE=4D0*PARU(102)-1D0
79393         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
79394         HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
79395         RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
79396      &  ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
79397      &  (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
79398      &  1D0)*HF1W)
79399       ENDIF
79400  
79401 C...Choose flavour. Gives charge and velocity.
79402       NTRY=0
79403   100 NTRY=NTRY+1
79404       IF(NTRY.GT.100) THEN
79405         CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
79406         KFLC=0
79407         RETURN
79408       ENDIF
79409       KFLC=KFL
79410       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
79411       MSTJ(93)=1
79412       PMQ=PYMASS(KFLC)
79413       IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
79414       QF=KCHG(KFLC,1)/3D0
79415       VQ=1D0
79416       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
79417  
79418 C...Calculate weight in QED or QFD case.
79419       IF(MSTJ(102).LE.1) THEN
79420         RF=QF**2
79421         RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
79422       ELSE
79423         VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
79424         RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
79425         RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
79426      &  VQ**3*HF1W
79427         IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
79428       ENDIF
79429  
79430 C...Weighting or new event (radiative photon). Cross-section update.
79431       IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
79432       PARJ(158)=PARJ(158)+1D0
79433       IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
79434       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
79435       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
79436       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
79437       PARJ(148)=PARJ(144)*86.8D0/ECM**2
79438  
79439       RETURN
79440       END
79441  
79442 C*********************************************************************
79443  
79444 C...PYXJET
79445 C...Selects number of jets in matrix element approach.
79446  
79447       SUBROUTINE PYXJET(ECM,NJET,CUT)
79448  
79449 C...Double precision and integer declarations.
79450       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79451       IMPLICIT INTEGER(I-N)
79452       INTEGER PYK,PYCHGE,PYCOMP
79453 C...Commonblocks.
79454       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79455       SAVE /PYDAT1/
79456 C...Local array and data.
79457       DIMENSION ZHUT(5)
79458       DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
79459  
79460 C...Trivial result for two-jets only, including parton shower.
79461       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
79462         CUT=0D0
79463  
79464 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
79465       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
79466         CF=4D0/3D0
79467         IF(MSTJ(109).EQ.2) CF=1D0
79468         IF(MSTJ(111).EQ.0) THEN
79469           Q2=ECM**2
79470           Q2R=ECM**2
79471         ELSEIF(MSTU(111).EQ.0) THEN
79472           PARJ(169)=MIN(1D0,PARJ(129))
79473           Q2=PARJ(169)*ECM**2
79474           PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
79475      &    ((33D0-2D0*MSTU(112))*PARU(111)))))
79476           Q2R=PARJ(168)*ECM**2
79477         ELSE
79478           PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
79479           Q2=PARJ(169)*ECM**2
79480           PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
79481      &    (2D0*PARU(112)/ECM)**2))
79482           Q2R=PARJ(168)*ECM**2
79483         ENDIF
79484  
79485 C...alpha_strong for R and R itself.
79486         ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
79487         IF(IABS(MSTJ(101)).EQ.1) THEN
79488           RQCD=1D0+ALSPI
79489         ELSEIF(MSTJ(109).EQ.0) THEN
79490           RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
79491           IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
79492      &    (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
79493         ELSE
79494           RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
79495         ENDIF
79496  
79497 C...alpha_strong for jet rate. Initial value for y cut.
79498         ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
79499         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
79500         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
79501      &  CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
79502         IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
79503  
79504 C...Parametrization of first order three-jet cross-section.
79505   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
79506           PARJ(152)=0D0
79507         ELSE
79508           PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
79509      &    LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
79510      &    (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
79511      &    (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
79512           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
79513      &    PARJ(152)=0D0
79514         ENDIF
79515  
79516 C...Parametrization of second order three-jet cross-section.
79517         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
79518      &  CUT.GE.0.25D0) THEN
79519           PARJ(153)=0D0
79520         ELSEIF(MSTJ(110).LE.1) THEN
79521           CT=LOG(1D0/CUT-2D0)
79522           PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
79523      &    0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
79524  
79525 C...Interpolation in second/first order ratio for Zhu parametrization.
79526         ELSEIF(MSTJ(110).EQ.2) THEN
79527           IZA=0
79528           DO 110 IY=1,5
79529             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
79530   110     CONTINUE
79531           IF(IZA.NE.0) THEN
79532             ZHURAT=ZHUT(IZA)
79533           ELSE
79534             IZ=100D0*CUT
79535             ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
79536           ENDIF
79537           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
79538         ENDIF
79539  
79540 C...Shift in second order three-jet cross-section with optimized Q^2.
79541         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
79542      &  .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
79543      &  (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
79544  
79545 C...Parametrization of second order four-jet cross-section.
79546         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
79547           PARJ(154)=0D0
79548         ELSE
79549           CT=LOG(1D0/CUT-5D0)
79550           IF(CUT.LE.0.018D0) THEN
79551             XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
79552             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
79553      &      0.4059D0*CT**2)
79554             XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
79555             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
79556           ELSE
79557             XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
79558             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
79559      &      0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
79560             XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
79561      &      0.002093D0*CT**3)
79562             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
79563           ENDIF
79564           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
79565           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
79566         ENDIF
79567  
79568 C...If negative three-jet rate, change y' optimization parameter.
79569         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
79570      &  PARJ(169).LT.0.99D0) THEN
79571           PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
79572           Q2=PARJ(169)*ECM**2
79573           ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
79574           GOTO 100
79575         ENDIF
79576  
79577 C...If too high cross-section, use harder cuts, or fail.
79578         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
79579           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
79580      &    PARJ(169).LT.0.99D0) THEN
79581             PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
79582             Q2=PARJ(169)*ECM**2
79583             ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
79584             GOTO 100
79585           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
79586             CALL PYERRM(26,
79587      &      '(PYXJET:) no allowed y cut value for Zhu parametrization')
79588           ENDIF
79589           CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
79590      &    PARJ(154))**(-1D0/3D0)
79591           IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
79592           GOTO 100
79593         ENDIF
79594  
79595 C...Scalar gluon (first order only).
79596       ELSE
79597         ALSPI=PYALPS(ECM**2)/PARU(1)
79598         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
79599         PARJ(152)=0D0
79600         IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
79601      &  LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
79602         PARJ(153)=0D0
79603         PARJ(154)=0D0
79604       ENDIF
79605  
79606 C...Select number of jets.
79607       PARJ(150)=CUT
79608       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
79609         NJET=2
79610       ELSEIF(MSTJ(101).LE.0) THEN
79611         NJET=MIN(4,2-MSTJ(101))
79612       ELSE
79613         RNJ=PYR(0)
79614         NJET=2
79615         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
79616         IF(PARJ(154).GT.RNJ) NJET=4
79617       ENDIF
79618  
79619       RETURN
79620       END
79621  
79622 C*********************************************************************
79623  
79624 C...PYX3JT
79625 C...Selects the kinematical variables of three-jet events.
79626  
79627       SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
79628  
79629 C...Double precision and integer declarations.
79630       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79631       IMPLICIT INTEGER(I-N)
79632       INTEGER PYK,PYCHGE,PYCOMP
79633 C...Commonblocks.
79634       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79635       SAVE /PYDAT1/
79636 C...Local array.
79637       DIMENSION ZHUP(5,12)
79638  
79639 C...Coefficients of Zhu second order parametrization.
79640       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
79641      &18.29D0,  89.56D0,  4.541D0,  -52.09D0, -109.8D0,  24.90D0,
79642      &11.63D0,  3.683D0,  17.50D0,0.002440D0, -1.362D0,-0.3537D0,
79643      &11.42D0,  6.299D0, -22.55D0,  -8.915D0,  59.25D0, -5.855D0,
79644      &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
79645      &7.847D0, -3.964D0, -35.83D0,   1.178D0,  29.39D0, 0.2806D0,
79646      &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
79647      &5.441D0, -56.89D0, -50.27D0,   15.13D0,  114.3D0, -18.19D0,
79648      &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
79649      &-17.65D0,  51.44D0, -58.32D0,   70.95D0, -255.7D0, -78.99D0,
79650      &476.9D0,  29.65D0, -239.3D0,  0.4745D0, -1.174D0,  6.081D0/
79651  
79652 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
79653       DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
79654      &X**7/49D0
79655  
79656 C...Event type. Mass effect factors and other common constants.
79657       MSTJ(120)=2
79658       MSTJ(121)=0
79659       PMQ=PYMASS(KFL)
79660       QME=(2D0*PMQ/ECM)**2
79661       IF(MSTJ(109).NE.1) THEN
79662         CUTL=LOG(CUT)
79663         CUTD=LOG(1D0/CUT-2D0)
79664         IF(MSTJ(109).EQ.0) THEN
79665           CF=4D0/3D0
79666           CN=3D0
79667           TR=2D0
79668           WTMX=MIN(20D0,37D0-6D0*CUTD)
79669           IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
79670         ELSE
79671           CF=1D0
79672           CN=0D0
79673           TR=12D0
79674           WTMX=0D0
79675         ENDIF
79676  
79677 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
79678         ALS2PI=PARU(118)/PARU(2)
79679         WTOPT=0D0
79680         IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
79681      &  LOG(PARJ(169))*ALS2PI
79682         WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
79683  
79684 C...Choose three-jet events in allowed region.
79685   100   NJET=3
79686   110   Y13L=CUTL+CUTD*PYR(0)
79687         Y23L=CUTL+CUTD*PYR(0)
79688         Y13=EXP(Y13L)
79689         Y23=EXP(Y23L)
79690         Y12=1D0-Y13-Y23
79691         IF(Y12.LE.CUT) GOTO 110
79692         IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
79693  
79694 C...Second order corrections.
79695         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
79696           Y12L=LOG(Y12)
79697           Y13M=LOG(1D0-Y13)
79698           Y23M=LOG(1D0-Y23)
79699           Y12M=LOG(1D0-Y12)
79700           IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
79701           IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
79702           IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
79703           IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
79704           IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
79705           IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
79706           WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
79707           WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
79708      &    2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
79709      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
79710      &    11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
79711      &    (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
79712      &    TR*(2D0*CUTL/3D0-10D0/9D0)+
79713      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
79714      &    Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
79715      &    (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
79716      &    Y13*Y23)/(Y12+Y13)**2)/WT1+
79717      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
79718      &    ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
79719      &    Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
79720      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
79721      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
79722      &    2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
79723      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
79724           IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
79725           IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
79726           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
79727  
79728         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
79729 C...Second order corrections; Zhu parametrization of ERT.
79730           ZX=(Y23-Y13)**2
79731           ZY=1D0-Y12
79732           IZA=0
79733           DO 120 IY=1,5
79734             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
79735   120     CONTINUE
79736           IF(IZA.NE.0) THEN
79737             IZ=IZA
79738             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
79739      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
79740      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
79741      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
79742           ELSE
79743             IZ=100D0*CUT
79744             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
79745      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
79746      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
79747      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
79748             IZ=IZ+1
79749             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
79750      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
79751      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
79752      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
79753             WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
79754           ENDIF
79755           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
79756           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
79757           PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
79758         ENDIF
79759  
79760 C...Impose mass cuts (gives two jets). For fixed jet number new try.
79761         X1=1D0-Y23
79762         X2=1D0-Y13
79763         X3=1D0-Y12
79764         IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
79765         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
79766      &  0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
79767      &  (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
79768         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
79769  
79770 C...Scalar gluon model (first order only, no mass effects).
79771       ELSE
79772   130   NJET=3
79773   140   X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
79774         IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
79775         YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
79776         X1=1D0-0.5D0*(X3+YD)
79777         X2=1D0-0.5D0*(X3-YD)
79778         IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
79779         IF(MSTJ(102).GE.2) THEN
79780           IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
79781      &    X3**2*PYR(0)) NJET=2
79782         ENDIF
79783         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
79784       ENDIF
79785  
79786       RETURN
79787       END
79788  
79789 C*********************************************************************
79790  
79791 C...PYX4JT
79792 C...Selects the kinematical variables of four-jet events.
79793  
79794       SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
79795  
79796 C...Double precision and integer declarations.
79797       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79798       IMPLICIT INTEGER(I-N)
79799       INTEGER PYK,PYCHGE,PYCOMP
79800 C...Commonblocks.
79801       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79802       SAVE /PYDAT1/
79803 C...Local arrays.
79804       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
79805  
79806 C...Common constants. Colour factors for QCD and Abelian gluon theory.
79807       PMQ=PYMASS(KFL)
79808       QME=(2D0*PMQ/ECM)**2
79809       CT=LOG(1D0/CUT-5D0)
79810       IF(MSTJ(109).EQ.0) THEN
79811         CF=4D0/3D0
79812         CN=3D0
79813         TR=2.5D0
79814       ELSE
79815         CF=1D0
79816         CN=0D0
79817         TR=15D0
79818       ENDIF
79819  
79820 C...Choice of process (qqbargg or qqbarqqbar).
79821   100 NJET=4
79822       IT=1
79823       IF(PARJ(155).GT.PYR(0)) IT=2
79824       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
79825       IF(IT.EQ.1) WTMX=0.7D0/CUT**2
79826       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
79827       IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
79828       ID=1
79829  
79830 C...Sample the five kinematical variables (for qqgg preweighted in y34).
79831   110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
79832       Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
79833       IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
79834       IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
79835       IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
79836       VT=PYR(0)
79837       CP=COS(PARU(1)*PYR(0))
79838       Y14=(Y134-Y34)*VT
79839       Y13=Y134-Y14-Y34
79840       VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
79841       Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
79842      &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
79843       Y23=Y234-Y34-Y24
79844       Y12=1D0-Y134-Y23-Y24
79845       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
79846       Y123=Y12+Y13+Y23
79847       Y124=Y12+Y14+Y24
79848  
79849 C...Calculate matrix elements for qqgg or qqqq process.
79850       IC=0
79851       WTTOT=0D0
79852   120 IC=IC+1
79853       IF(IT.EQ.1) THEN
79854         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
79855      &  3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
79856      &  Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
79857      &  Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
79858      &  2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
79859      &  (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
79860      &  Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
79861      &  (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
79862         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
79863      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
79864      &  Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
79865      &  Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
79866         WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
79867      &  2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
79868      &  Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
79869      &  3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
79870      &  3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
79871      &  (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
79872      &  3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
79873      &  2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
79874      &  2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
79875      &  3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
79876      &  2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
79877      &  2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
79878         WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
79879      &  4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
79880      &  Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
79881      &  4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
79882      &  2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
79883      &  4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
79884      &  (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
79885      &  2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
79886      &  2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
79887      &  4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
79888      &  Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
79889      &  4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
79890      &  4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
79891      &  2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
79892      &  2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
79893      &  Y12*Y13**2)/(4D0*Y34**2*Y134**2)
79894         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
79895      &  CN*WTC(IC))/8D0
79896       ELSE
79897         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
79898      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
79899      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
79900      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
79901      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
79902      &  Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
79903      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
79904      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
79905      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
79906         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
79907      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
79908      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
79909      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
79910      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
79911      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
79912      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
79913      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
79914         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
79915       ENDIF
79916  
79917 C...Permutations of momenta in matrix element. Weighting.
79918   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
79919         YSAV=Y13
79920         Y13=Y14
79921         Y14=YSAV
79922         YSAV=Y23
79923         Y23=Y24
79924         Y24=YSAV
79925         YSAV=Y123
79926         Y123=Y124
79927         Y124=YSAV
79928       ENDIF
79929       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
79930         YSAV=Y13
79931         Y13=Y23
79932         Y23=YSAV
79933         YSAV=Y14
79934         Y14=Y24
79935         Y24=YSAV
79936         YSAV=Y134
79937         Y134=Y234
79938         Y234=YSAV
79939       ENDIF
79940       IF(IC.LE.3) GOTO 120
79941       IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
79942       IC=5
79943  
79944 C...qqgg events: string configuration and event type.
79945       IF(IT.EQ.1) THEN
79946         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
79947           PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
79948      &    WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
79949           IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
79950      &    WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
79951           IF(ID.EQ.2) GOTO 130
79952         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
79953           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
79954           IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
79955           IF(ID.EQ.2) GOTO 130
79956         ENDIF
79957         MSTJ(120)=3
79958         IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
79959      &  WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
79960         KFLN=21
79961  
79962 C...Mass cuts. Kinematical variables out.
79963         IF(Y12.LE.CUT+QME) NJET=2
79964         IF(NJET.EQ.2) GOTO 150
79965         Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
79966         X1=1D0-(1D0-Q12)*Y234-Q12*Y134
79967         X4=1D0-(1D0-Q12)*Y134-Q12*Y234
79968         X2=1D0-Y124
79969         X12=(1D0-Q12)*Y13+Q12*Y23
79970         X14=Y12-0.5D0*QME
79971         IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
79972  
79973 C...qqbarqqbar events: string configuration, choose new flavour.
79974       ELSE
79975         IF(ID.EQ.1) THEN
79976           WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
79977           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
79978           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
79979           IF(WTR.LT.WTD(4)) ID=4
79980           IF(ID.GE.2) GOTO 130
79981         ENDIF
79982         MSTJ(120)=5
79983         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
79984   140   KFLN=1+INT(5D0*PYR(0))
79985         IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
79986         IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
79987         IF(KFLN.GT.MSTJ(104)) NJET=2
79988         PMQN=PYMASS(KFLN)
79989         QMEN=(2D0*PMQN/ECM)**2
79990  
79991 C...Mass cuts. Kinematical variables out.
79992         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
79993         IF(NJET.EQ.2) GOTO 150
79994         Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
79995         Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
79996         X1=1D0-(1D0-Q24)*Y123-Q24*Y134
79997         X4=1D0-(1D0-Q24)*Y134-Q24*Y123
79998         X2=1D0-(1D0-Q13)*Y234-Q13*Y124
79999         X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
80000      &  Q13*Y23)
80001         X14=Y24-0.5D0*QME
80002         X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
80003      &  Q13*Y14)
80004         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
80005      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
80006         IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
80007       ENDIF
80008   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
80009  
80010       RETURN
80011       END
80012  
80013 C*********************************************************************
80014  
80015 C...PYXDIF
80016 C...Gives the angular orientation of events.
80017  
80018       SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
80019  
80020 C...Double precision and integer declarations.
80021       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80022       IMPLICIT INTEGER(I-N)
80023       INTEGER PYK,PYCHGE,PYCOMP
80024 C...Commonblocks.
80025       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
80026       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80027       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
80028       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
80029  
80030 C...Charge. Factors depending on polarization for QED case.
80031       QF=KCHG(KFL,1)/3D0
80032       POLL=1D0-PARJ(131)*PARJ(132)
80033       POLD=PARJ(132)-PARJ(131)
80034       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
80035         HF1=POLL
80036         HF2=0D0
80037         HF3=PARJ(133)**2
80038         HF4=0D0
80039  
80040 C...Factors depending on flavour, energy and polarization for QFD case.
80041       ELSE
80042         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
80043         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
80044         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
80045         AE=-1D0
80046         VE=4D0*PARU(102)-1D0
80047         AF=SIGN(1D0,QF)
80048         VF=AF-4D0*QF*PARU(102)
80049         HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
80050      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
80051         HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
80052      &  (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
80053         HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
80054      &  SFW*SFF**2*(VE**2-AE**2))
80055         HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
80056      &  SFF*AE
80057       ENDIF
80058  
80059 C...Mass factor. Differential cross-sections for two-jet events.
80060       SQ2=SQRT(2D0)
80061       QME=0D0
80062       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
80063      &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
80064       IF(NJET.EQ.2) THEN
80065         SIGU=4D0*SQRT(1D0-QME)
80066         SIGL=2D0*QME*SQRT(1D0-QME)
80067         SIGT=0D0
80068         SIGI=0D0
80069         SIGA=0D0
80070         SIGP=4D0
80071  
80072 C...Kinematical variables. Reduce four-jet event to three-jet one.
80073       ELSE
80074         IF(NJET.EQ.3) THEN
80075           X1=2D0*P(NC+1,4)/ECM
80076           X2=2D0*P(NC+3,4)/ECM
80077         ELSE
80078           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
80079      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
80080           X1=2D0*P(NC+1,4)/ECMR
80081           X2=2D0*P(NC+4,4)/ECMR
80082         ENDIF
80083  
80084 C...Differential cross-sections for three-jet (or reduced four-jet).
80085         XQ=(1D0-X1)/(1D0-X2)
80086         CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
80087         ST12=SQRT(1D0-CT12**2)
80088         IF(MSTJ(109).NE.1) THEN
80089           SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
80090      &    QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
80091           SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
80092      &    0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
80093      &    X2)*XQ
80094           SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
80095           SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
80096      &    QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
80097           SIGA=X2**2*ST12/SQ2
80098           SIGP=2D0*(X1**2-X2**2*CT12)
80099  
80100 C...Differential cross-sect for scalar gluons (no mass effects).
80101         ELSE
80102           X3=2D0-X1-X2
80103           XT=X2*ST12
80104           CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
80105           SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
80106      &    PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
80107           SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
80108      &    PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
80109           SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
80110      &    PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
80111           SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
80112      &    PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
80113           SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
80114           SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
80115         ENDIF
80116       ENDIF
80117  
80118 C...Upper bounds for differential cross-section.
80119       HF1A=ABS(HF1)
80120       HF2A=ABS(HF2)
80121       HF3A=ABS(HF3)
80122       HF4A=ABS(HF4)
80123       SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
80124      &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
80125      &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
80126      &2D0*HF2A*ABS(SIGP)
80127  
80128 C...Generate angular orientation according to differential cross-sect.
80129   100 CHI=PARU(2)*PYR(0)
80130       CTHE=2D0*PYR(0)-1D0
80131       PHI=PARU(2)*PYR(0)
80132       CCHI=COS(CHI)
80133       SCHI=SIN(CHI)
80134       C2CHI=COS(2D0*CHI)
80135       S2CHI=SIN(2D0*CHI)
80136       THE=ACOS(CTHE)
80137       STHE=SIN(THE)
80138       C2PHI=COS(2D0*(PHI-PARJ(134)))
80139       S2PHI=SIN(2D0*(PHI-PARJ(134)))
80140       SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
80141      &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
80142      &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
80143      &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
80144      &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
80145      &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
80146      &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
80147       IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
80148  
80149       RETURN
80150       END
80151  
80152 C*********************************************************************
80153  
80154 C...PYONIA
80155 C...Generates Upsilon and toponium decays into three gluons
80156 C...or two gluons and a photon.
80157  
80158       SUBROUTINE PYONIA(KFL,ECM)
80159  
80160 C...Double precision and integer declarations.
80161       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80162       IMPLICIT INTEGER(I-N)
80163       INTEGER PYK,PYCHGE,PYCOMP
80164 C...Commonblocks.
80165       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
80166       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80167       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
80168       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
80169  
80170 C...Printout. Check input parameters.
80171       IF(MSTU(12).NE.12345) CALL PYLIST(0)
80172       IF(KFL.LT.0.OR.KFL.GT.8) THEN
80173         CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
80174         IF(MSTU(21).GE.1) RETURN
80175       ENDIF
80176       IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
80177         CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
80178         IF(MSTU(21).GE.1) RETURN
80179       ENDIF
80180  
80181 C...Initial e+e- and onium state (optional).
80182       NC=0
80183       IF(MSTJ(115).GE.2) THEN
80184         NC=NC+2
80185         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
80186         K(NC-1,1)=21
80187         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
80188         K(NC,1)=21
80189       ENDIF
80190       KFLC=IABS(KFL)
80191       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
80192         NC=NC+1
80193         KF=110*KFLC+3
80194         MSTU10=MSTU(10)
80195         MSTU(10)=1
80196         P(NC,5)=ECM
80197         CALL PY1ENT(NC,KF,ECM,0D0,0D0)
80198         K(NC,1)=21
80199         K(NC,3)=1
80200         MSTU(10)=MSTU10
80201       ENDIF
80202  
80203 C...Choose x1 and x2 according to matrix element.
80204       NTRY=0
80205   100 X1=PYR(0)
80206       X2=PYR(0)
80207       X3=2D0-X1-X2
80208       IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
80209      &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
80210       NTRY=NTRY+1
80211       NJET=3
80212       IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
80213       IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
80214  
80215 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
80216       MSTU(111)=MSTJ(108)
80217       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
80218      &MSTU(111)=1
80219       PARU(112)=PARJ(121)
80220       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
80221       QF=0D0
80222       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
80223       RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
80224       MK=0
80225       ECMC=ECM
80226       IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
80227         IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
80228      &  NJET=2
80229         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
80230         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
80231       ELSE
80232         MK=1
80233         ECMC=SQRT(1D0-X1)*ECM
80234         IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
80235         K(NC+1,1)=1
80236         K(NC+1,2)=22
80237         K(NC+1,4)=0
80238         K(NC+1,5)=0
80239         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
80240         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
80241         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
80242         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
80243         NJET=2
80244         IF(ECMC.LT.4D0*PARJ(127)) THEN
80245           MSTU10=MSTU(10)
80246           MSTU(10)=1
80247           P(NC+2,5)=ECMC
80248           CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
80249           MSTU(10)=MSTU10
80250           NJET=0
80251         ENDIF
80252       ENDIF
80253       DO 110 IP=NC+1,N
80254         K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
80255   110 CONTINUE
80256  
80257 C...Differential cross-sections. Upper limit for cross-section.
80258       IF(MSTJ(106).EQ.1) THEN
80259         SQ2=SQRT(2D0)
80260         HF1=1D0-PARJ(131)*PARJ(132)
80261         HF3=PARJ(133)**2
80262         CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
80263         ST13=SQRT(1D0-CT13**2)
80264         SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
80265         SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
80266         SIGT=0.5D0*SIGL
80267         SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
80268         SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
80269      &  2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
80270  
80271 C...Angular orientation of event.
80272   120   CHI=PARU(2)*PYR(0)
80273         CTHE=2D0*PYR(0)-1D0
80274         PHI=PARU(2)*PYR(0)
80275         CCHI=COS(CHI)
80276         SCHI=SIN(CHI)
80277         C2CHI=COS(2D0*CHI)
80278         S2CHI=SIN(2D0*CHI)
80279         THE=ACOS(CTHE)
80280         STHE=SIN(THE)
80281         C2PHI=COS(2D0*(PHI-PARJ(134)))
80282         S2PHI=SIN(2D0*(PHI-PARJ(134)))
80283         SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
80284      &  STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
80285      &  C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
80286      &  2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
80287      &  (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
80288         IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
80289         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
80290         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
80291       ENDIF
80292  
80293 C...Generate parton shower. Rearrange along strings and check.
80294       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
80295         CALL PYSHOW(NC+MK+1,-NJET,ECMC)
80296         MSTJ14=MSTJ(14)
80297         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
80298         IF(MSTJ(105).GE.0) MSTU(28)=0
80299         CALL PYPREP(0)
80300         MSTJ(14)=MSTJ14
80301         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
80302       ENDIF
80303  
80304 C...Generate fragmentation. Information for PYTABU:
80305       IF(MSTJ(105).EQ.1) CALL PYEXEC
80306       MSTU(161)=110*KFLC+3
80307       MSTU(162)=0
80308  
80309       RETURN
80310       END
80311  
80312 C*********************************************************************
80313  
80314 C...PYBOOK
80315 C...Books a histogram.
80316  
80317       SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
80318  
80319 C...Double precision declaration.
80320       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80321       IMPLICIT INTEGER(I-N)
80322 C...Commonblock.
80323       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80324       SAVE /PYBINS/
80325 C...Local character variables.
80326       CHARACTER TITLE*(*), TITFX*60
80327  
80328 C...Check that input is sensible. Find initial address in memory.
80329       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
80330      &'(PYBOOK:) not allowed histogram number')
80331       IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
80332      &'(PYBOOK:) not allowed number of bins')
80333       IF(XL.GE.XU) CALL PYERRM(28,
80334      &'(PYBOOK:) x limits in wrong order')
80335       INDX(ID)=IHIST(4)
80336       IHIST(4)=IHIST(4)+28+NX
80337       IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
80338      &'(PYBOOK:) out of histogram space')
80339       IS=INDX(ID)
80340  
80341 C...Store histogram size and reset contents.
80342       BIN(IS+1)=NX
80343       BIN(IS+2)=XL
80344       BIN(IS+3)=XU
80345       BIN(IS+4)=(XU-XL)/NX
80346       CALL PYNULL(ID)
80347  
80348 C...Store title by conversion to integer to double precision.
80349       TITFX=TITLE//' '
80350       DO 100 IT=1,20
80351         BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
80352      &  256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
80353   100 CONTINUE
80354  
80355       RETURN
80356       END
80357  
80358 C*********************************************************************
80359  
80360 C...PYFILL
80361 C...Fills entry in histogram.
80362  
80363       SUBROUTINE PYFILL(ID,X,W)
80364  
80365 C...Double precision declaration.
80366       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80367       IMPLICIT INTEGER(I-N)
80368 C...Commonblock.
80369       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80370       SAVE /PYBINS/
80371  
80372 C...Find initial address in memory. Increase number of entries.
80373       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
80374      &'(PYFILL:) not allowed histogram number')
80375       IS=INDX(ID)
80376       IF(IS.EQ.0) CALL PYERRM(28,
80377      &'(PYFILL:) filling unbooked histogram')
80378       BIN(IS+5)=BIN(IS+5)+1D0
80379  
80380 C...Find bin in x, including under/overflow, and fill.
80381       IF(X.LT.BIN(IS+2)) THEN
80382         BIN(IS+6)=BIN(IS+6)+W
80383       ELSEIF(X.GE.BIN(IS+3)) THEN
80384         BIN(IS+8)=BIN(IS+8)+W
80385       ELSE
80386         BIN(IS+7)=BIN(IS+7)+W
80387         IX=(X-BIN(IS+2))/BIN(IS+4)
80388         IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
80389         BIN(IS+9+IX)=BIN(IS+9+IX)+W
80390       ENDIF
80391  
80392       RETURN
80393       END
80394  
80395 C*********************************************************************
80396  
80397 C...PYFACT
80398 C...Multiplies histogram contents by factor.
80399  
80400       SUBROUTINE PYFACT(ID,F)
80401  
80402 C...Double precision declaration.
80403       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80404       IMPLICIT INTEGER(I-N)
80405 C...Commonblock.
80406       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80407       SAVE /PYBINS/
80408  
80409 C...Find initial address in memory. Multiply all contents bins.
80410       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
80411      &'(PYFACT:) not allowed histogram number')
80412       IS=INDX(ID)
80413       IF(IS.EQ.0) CALL PYERRM(28,
80414      &'(PYFACT:) scaling unbooked histogram')
80415       DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
80416         BIN(IX)=F*BIN(IX)
80417   100 CONTINUE
80418  
80419       RETURN
80420       END
80421  
80422 C*********************************************************************
80423  
80424 C...PYOPER
80425 C...Performs operations between histograms.
80426  
80427       SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
80428  
80429 C...Double precision declaration.
80430       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80431       IMPLICIT INTEGER(I-N)
80432 C...Commonblock.
80433       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80434       SAVE /PYBINS/
80435 C...Character variable.
80436       CHARACTER OPER*(*)
80437  
80438 C...Find initial addresses in memory, and histogram size.
80439       IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
80440      &'(PYFACT:) not allowed histogram number')
80441       IS1=INDX(ID1)
80442       IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
80443       IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
80444       NX=NINT(BIN(IS3+1))
80445       IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
80446  
80447 C...Update info on number of histogram entries.
80448       IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
80449         BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
80450       ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
80451         BIN(IS3+5)=BIN(IS1+5)
80452       ENDIF
80453  
80454 C...Operations on pair of histograms: addition, subtraction,
80455 C...multiplication, division.
80456       IF(OPER.EQ.'+') THEN
80457         DO 100 IX=6,8+NX
80458           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
80459   100   CONTINUE
80460       ELSEIF(OPER.EQ.'-') THEN
80461         DO 110 IX=6,8+NX
80462           BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
80463   110   CONTINUE
80464       ELSEIF(OPER.EQ.'*') THEN
80465         DO 120 IX=6,8+NX
80466           BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
80467   120   CONTINUE
80468       ELSEIF(OPER.EQ.'/') THEN
80469         DO 130 IX=6,8+NX
80470           FA2=F2*BIN(IS2+IX)
80471           IF(ABS(FA2).LE.1D-20) THEN
80472             BIN(IS3+IX)=0D0
80473           ELSE
80474             BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
80475           ENDIF
80476   130   CONTINUE
80477  
80478 C...Operations on single histogram: multiplication+addition,
80479 C...square root+addition, logarithm+addition.
80480       ELSEIF(OPER.EQ.'A') THEN
80481         DO 140 IX=6,8+NX
80482           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
80483   140   CONTINUE
80484       ELSEIF(OPER.EQ.'S') THEN
80485         DO 150 IX=6,8+NX
80486           BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
80487   150   CONTINUE
80488       ELSEIF(OPER.EQ.'L') THEN
80489         ZMIN=1D20
80490         DO 160 IX=9,8+NX
80491           IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
80492      &    ZMIN=0.8D0*BIN(IS1+IX)
80493   160   CONTINUE
80494         DO 170 IX=6,8+NX
80495           BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
80496   170   CONTINUE
80497  
80498 C...Operation on two or three histograms: average and
80499 C...standard deviation.
80500       ELSEIF(OPER.EQ.'M') THEN
80501         DO 180 IX=6,8+NX
80502           IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
80503             BIN(IS2+IX)=0D0
80504           ELSE
80505             BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
80506           ENDIF
80507           IF(ID3.NE.0) THEN
80508             IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
80509               BIN(IS3+IX)=0D0
80510             ELSE
80511               BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
80512      &        BIN(IS2+IX)**2))
80513             ENDIF
80514           ENDIF
80515           BIN(IS1+IX)=F1*BIN(IS1+IX)
80516   180   CONTINUE
80517       ENDIF
80518  
80519       RETURN
80520       END
80521  
80522 C*********************************************************************
80523  
80524 C...PYHIST
80525 C...Prints and resets all histograms.
80526  
80527       SUBROUTINE PYHIST
80528  
80529 C...Double precision declaration.
80530       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80531       IMPLICIT INTEGER(I-N)
80532 C...Commonblock.
80533       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80534       SAVE /PYBINS/
80535  
80536 C...Loop over histograms, print and reset used ones.
80537       DO 100 ID=1,IHIST(1)
80538         IS=INDX(ID)
80539         IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
80540           CALL PYPLOT(ID)
80541           CALL PYNULL(ID)
80542         ENDIF
80543   100 CONTINUE
80544  
80545       RETURN
80546       END
80547  
80548 C*********************************************************************
80549  
80550 C...PYPLOT
80551 C...Prints a histogram (but does not reset it).
80552  
80553       SUBROUTINE PYPLOT(ID)
80554  
80555 C...Double precision declaration.
80556       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80557       IMPLICIT INTEGER(I-N)
80558 C...Commonblocks.
80559       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80560       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80561       SAVE /PYDAT1/,/PYBINS/
80562 C...Local arrays and character variables.
80563       DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
80564       CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
80565  
80566 C...Steps in histogram scale. Character sequence.
80567       DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
80568       DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
80569  
80570 C...Find initial address in memory; skip if empty histogram.
80571       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
80572       IS=INDX(ID)
80573       IF(IS.EQ.0) RETURN
80574       IF(NINT(BIN(IS+5)).LE.0) THEN
80575         WRITE(MSTU(11),5000) ID
80576         RETURN
80577       ENDIF
80578  
80579 C...Number of histogram lines and x bins.
80580       LIN=IHIST(3)-18
80581       NX=NINT(BIN(IS+1))
80582  
80583 C...Extract title by conversion from double precision via integer.
80584       DO 100 IT=1,20
80585         IEQ=NINT(BIN(IS+8+NX+IT))
80586         TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
80587      &  //CHAR(MOD(IEQ,256))
80588   100 CONTINUE
80589  
80590 C...Find time; print title.
80591       CALL PYTIME(IDATI)
80592       IF(IDATI(1).GT.0) THEN
80593         WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
80594       ELSE
80595         WRITE(MSTU(11),5200) ID, TITLE
80596       ENDIF
80597  
80598 C...Find minimum and maximum bin content.
80599       YMIN=BIN(IS+9)
80600       YMAX=BIN(IS+9)
80601       DO 110 IX=IS+10,IS+8+NX
80602         IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
80603         IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
80604   110 CONTINUE
80605  
80606 C...Determine scale and step size for y axis.
80607       IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
80608         IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
80609         IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
80610         IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
80611         IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
80612         IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
80613         DELY=DYAC(1)
80614         DO 120 IDEL=1,9
80615           IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
80616   120   CONTINUE
80617         DY=DELY*10D0**IPOT
80618  
80619 C...Convert bin contents to integer form; fractional fill in top row.
80620         DO 130 IX=1,NX
80621           CTA=ABS(BIN(IS+8+IX))/DY
80622           IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
80623           IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
80624   130   CONTINUE
80625         IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
80626         IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
80627  
80628 C...Print histogram row by row.
80629         DO 150 IR=IRMA,IRMI,-1
80630           IF(IR.EQ.0) GOTO 150
80631           OUT=' '
80632           DO 140 IX=1,NX
80633             IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
80634             IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
80635   140     CONTINUE
80636           WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
80637   150   CONTINUE
80638  
80639 C...Print sign and value of bin contents.
80640         IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
80641         OUT=' '
80642         DO 160 IX=1,NX
80643           IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
80644           IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
80645   160   CONTINUE
80646         WRITE(MSTU(11),5400) OUT
80647         DO 180 IR=4,1,-1
80648           DO 170 IX=1,NX
80649             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
80650   170     CONTINUE
80651           WRITE(MSTU(11),5500) IPOT+IR-4, OUT
80652   180   CONTINUE
80653  
80654 C...Print sign and value of lower bin edge.
80655         IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
80656      &  10.0001D0)-10
80657         OUT=' '
80658         DO 190 IX=1,NX
80659           IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
80660      &    OUT(IX:IX)=CHA(11)
80661           IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
80662   190   CONTINUE
80663         WRITE(MSTU(11),5600) OUT
80664         DO 210 IR=3,1,-1
80665           DO 200 IX=1,NX
80666             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
80667   200     CONTINUE
80668           WRITE(MSTU(11),5500) IPOT+IR-3, OUT
80669   210   CONTINUE
80670       ENDIF
80671  
80672 C...Calculate and print statistics.
80673       CSUM=0D0
80674       CXSUM=0D0
80675       CXXSUM=0D0
80676       DO 220 IX=1,NX
80677         CTA=ABS(BIN(IS+8+IX))
80678         X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
80679         CSUM=CSUM+CTA
80680         CXSUM=CXSUM+CTA*X
80681         CXXSUM=CXXSUM+CTA*X**2
80682   220 CONTINUE
80683       XMEAN=CXSUM/MAX(CSUM,1D-20)
80684       XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
80685       WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
80686      &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
80687  
80688 C...Formats for output.
80689  5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
80690  5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
80691      &I2,':',I2/)
80692  5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
80693  5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
80694  5400 FORMAT(/8X,'Contents',3X,A100)
80695  5500 FORMAT(9X,'*10**',I2,3X,A100)
80696  5600 FORMAT(/8X,'Low edge',3X,A100)
80697  5700 FORMAT(/5X,'Entries  =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
80698      &,D12.4,6X,'Low edge  =',D12.4/5X,'All chan =',D12.4,6X,
80699      &'Rms  =',D12.4,6X,'Overflow  =',D12.4,6X,'High edge =',D12.4)
80700  
80701       RETURN
80702       END
80703  
80704 C*********************************************************************
80705  
80706 C...PYNULL
80707 C...Resets bin contents of a histogram.
80708  
80709       SUBROUTINE PYNULL(ID)
80710  
80711 C...Double precision declaration.
80712       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80713       IMPLICIT INTEGER(I-N)
80714 C...Commonblock.
80715       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80716       SAVE /PYBINS/
80717  
80718       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
80719       IS=INDX(ID)
80720       IF(IS.EQ.0) RETURN
80721       DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
80722         BIN(IX)=0D0
80723   100 CONTINUE
80724  
80725       RETURN
80726       END
80727  
80728 C*********************************************************************
80729  
80730 C...PYDUMP
80731 C...Dumps histogram contents on file for reading by other program.
80732 C...Can also read back own dump.
80733  
80734       SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
80735  
80736 C...Double precision declaration.
80737       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80738       IMPLICIT INTEGER(I-N)
80739 C...Commonblock.
80740       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
80741       SAVE /PYBINS/
80742 C...Local arrays and character variables.
80743       DIMENSION IHI(*),ISS(100),VAL(5)
80744       CHARACTER TITLE*60,FORMAT*13
80745  
80746 C...Dump all histograms that have been booked,
80747 C...including titles and ranges, one after the other.
80748       IF(MDUMP.EQ.1) THEN
80749  
80750 C...Loop over histograms and find which are wanted and booked.
80751         IF(NHI.LE.0) THEN
80752           NW=IHIST(1)
80753         ELSE
80754           NW=NHI
80755         ENDIF
80756         DO 130 IW=1,NW
80757           IF(NHI.EQ.0) THEN
80758             ID=IW
80759           ELSE
80760             ID=IHI(IW)
80761           ENDIF
80762           IS=INDX(ID)
80763           IF(IS.NE.0) THEN
80764  
80765 C...Write title, histogram size, filling statistics.
80766             NX=NINT(BIN(IS+1))
80767             DO 100 IT=1,20
80768               IEQ=NINT(BIN(IS+8+NX+IT))
80769               TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
80770      &        CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
80771   100       CONTINUE
80772             WRITE(LFN,5100) ID,TITLE
80773             WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
80774             WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
80775      &      BIN(IS+8)
80776  
80777  
80778 C...Write histogram contents, in groups of five.
80779             DO 120 IXG=1,(NX+4)/5
80780               DO 110 IXV=1,5
80781                 IX=5*IXG+IXV-5
80782                 IF(IX.LE.NX) THEN
80783                   VAL(IXV)=BIN(IS+8+IX)
80784                 ELSE
80785                   VAL(IXV)=0D0
80786                 ENDIF
80787   110         CONTINUE
80788               WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
80789   120       CONTINUE
80790  
80791 C...Go to next histogram; finish.
80792           ELSEIF(NHI.GT.0) THEN
80793             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
80794           ENDIF
80795   130   CONTINUE
80796  
80797 C...Read back in histograms dumped MDUMP=1.
80798       ELSEIF(MDUMP.EQ.2) THEN
80799  
80800 C...Read histogram number, title and range, and book.
80801   140   READ(LFN,5100,END=170) ID,TITLE
80802         READ(LFN,5200) NX,XL,XU
80803         CALL PYBOOK(ID,TITLE,NX,XL,XU)
80804         IS=INDX(ID)
80805  
80806 C...Read filling statistics.
80807         READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
80808         BIN(IS+5)=DBLE(NENTRY)
80809  
80810 C...Read histogram contents, in groups of five.
80811         DO 160 IXG=1,(NX+4)/5
80812           READ(LFN,5400) (VAL(IXV),IXV=1,5)
80813           DO 150 IXV=1,5
80814             IX=5*IXG+IXV-5
80815             IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
80816   150     CONTINUE
80817   160   CONTINUE
80818  
80819 C...Go to next histogram; finish.
80820         GOTO 140
80821   170   CONTINUE
80822  
80823 C...Write histogram contents in column format,
80824 C...convenient e.g. for GNUPLOT input.
80825       ELSEIF(MDUMP.EQ.3) THEN
80826  
80827 C...Find addresses to wanted histograms.
80828         NSS=0
80829         IF(NHI.LE.0) THEN
80830           NW=IHIST(1)
80831         ELSE
80832           NW=NHI
80833         ENDIF
80834         DO 180 IW=1,NW
80835           IF(NHI.EQ.0) THEN
80836             ID=IW
80837           ELSE
80838             ID=IHI(IW)
80839           ENDIF
80840           IS=INDX(ID)
80841           IF(IS.NE.0.AND.NSS.LT.100) THEN
80842             NSS=NSS+1
80843             ISS(NSS)=IS
80844           ELSEIF(NSS.GE.100) THEN
80845             CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
80846           ELSEIF(NHI.GT.0) THEN
80847             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
80848           ENDIF
80849   180   CONTINUE
80850  
80851 C...Check that they have common number of x bins. Fix format.
80852         NX=NINT(BIN(ISS(1)+1))
80853         DO 190 IW=2,NSS
80854           IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
80855             CALL PYERRM(8,'(PYDUMP:) different number of bins')
80856             RETURN
80857           ENDIF
80858   190   CONTINUE
80859         FORMAT='(1P,000E12.4)'
80860         WRITE(FORMAT(5:7),'(I3)') NSS+1
80861  
80862 C...Write histogram contents; first column x values.
80863         DO 200 IX=1,NX
80864           X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
80865           WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
80866   200   CONTINUE
80867  
80868       ENDIF
80869  
80870 C...Formats for output.
80871  5100 FORMAT(I5,5X,A60)
80872  5200 FORMAT(I5,1P,2D12.4)
80873  5300 FORMAT(I12,1P,3D12.4)
80874  5400 FORMAT(1P,5D12.4)
80875  
80876       RETURN
80877       END
80878  
80879 C*********************************************************************
80880  
80881 C...PYSTOP
80882 C...Allows users to handle STOP statemens
80883  
80884       SUBROUTINE PYSTOP(MCOD)
80885  
80886 C...Double precision and integer declarations.
80887       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80888       IMPLICIT INTEGER(I-N)
80889       INTEGER PYK,PYCHGE,PYCOMP
80890 C...Commonblocks.
80891       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80892       SAVE /PYDAT1/
80893 
80894  
80895 C...Write message, then stop
80896       WRITE(MSTU(11),5000) MCOD
80897       STOP
80898 
80899  
80900 C...Formats for output.
80901  5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
80902       END
80903  
80904 C*********************************************************************
80905  
80906 C...PYKCUT
80907 C...Dummy routine, which the user can replace in order to make cuts on
80908 C...the kinematics on the parton level before the matrix elements are
80909 C...evaluated and the event is generated. The cross-section estimates
80910 C...will automatically take these cuts into account, so the given
80911 C...values are for the allowed phase space region only. MCUT=0 means
80912 C...that the event has passed the cuts, MCUT=1 that it has failed.
80913  
80914       SUBROUTINE PYKCUT(MCUT)
80915  
80916 C...Double precision and integer declarations.
80917       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80918       IMPLICIT INTEGER(I-N)
80919       INTEGER PYK,PYCHGE,PYCOMP
80920 C...Commonblocks.
80921       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80922       COMMON/PYINT1/MINT(400),VINT(400)
80923       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
80924       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
80925  
80926 C...Set default value (accepting event) for MCUT.
80927       MCUT=0
80928  
80929 C...Read out subprocess number.
80930       ISUB=MINT(1)
80931       ISTSB=ISET(ISUB)
80932  
80933 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
80934       TAU=VINT(21)
80935       YST=VINT(22)
80936       CTH=0D0
80937       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
80938       TAUP=0D0
80939       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
80940  
80941 C...Calculate x_1, x_2, x_F.
80942       IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
80943         X1=SQRT(TAU)*EXP(YST)
80944         X2=SQRT(TAU)*EXP(-YST)
80945       ELSE
80946         X1=SQRT(TAUP)*EXP(YST)
80947         X2=SQRT(TAUP)*EXP(-YST)
80948       ENDIF
80949       XF=X1-X2
80950  
80951 C...Calculate shat, that, uhat, p_T^2.
80952       SHAT=TAU*VINT(2)
80953       SQM3=VINT(63)
80954       SQM4=VINT(64)
80955       RM3=SQM3/SHAT
80956       RM4=SQM4/SHAT
80957       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
80958       RPTS=4D0*VINT(71)**2/SHAT
80959       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
80960       RM34=2D0*RM3*RM4
80961       RSQM=1D0+RM34
80962       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
80963       THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
80964       UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
80965       PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
80966  
80967 C...Decisions by user to be put here.
80968  
80969 C...Stop program if this routine is ever called.
80970 C...You should not copy these lines to your own routine.
80971       WRITE(MSTU(11),5000)
80972       CALL PYSTOP(6)
80973  
80974 C...Format for error printout.
80975  5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
80976      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80977      &1X,'Execution stopped!')
80978  
80979       RETURN
80980       END
80981  
80982 C*********************************************************************
80983  
80984 C...PYEVWT
80985 C...Dummy routine, which the user can replace in order to multiply the
80986 C...standard PYTHIA differential cross-section by a process- and
80987 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
80988 C...to generation of weighted events, with weight 1/WTXS, while for
80989 C...MSTP(142)=2 it corresponds to a modification of the underlying
80990 C...physics.
80991  
80992       SUBROUTINE PYEVWT(WTXS)
80993  
80994 C...Double precision and integer declarations.
80995       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80996       IMPLICIT INTEGER(I-N)
80997       INTEGER PYK,PYCHGE,PYCOMP
80998 C...Commonblocks.
80999       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81000       COMMON/PYINT1/MINT(400),VINT(400)
81001       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
81002       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
81003  
81004 C...Set default weight for WTXS.
81005       WTXS=1D0
81006  
81007 C...Read out subprocess number.
81008       ISUB=MINT(1)
81009       ISTSB=ISET(ISUB)
81010  
81011 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
81012       TAU=VINT(21)
81013       YST=VINT(22)
81014       CTH=0D0
81015       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
81016       TAUP=0D0
81017       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
81018  
81019 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
81020       X1=VINT(41)
81021       X2=VINT(42)
81022       XF=X1-X2
81023       SHAT=VINT(44)
81024       THAT=VINT(45)
81025       UHAT=VINT(46)
81026       PT2=VINT(48)
81027  
81028 C...Modifications by user to be put here.
81029  
81030 C...Stop program if this routine is ever called.
81031 C...You should not copy these lines to your own routine.
81032       WRITE(MSTU(11),5000)
81033       CALL PYSTOP(4)
81034  
81035 C...Format for error printout.
81036  5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
81037      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
81038      &1X,'Execution stopped!')
81039  
81040       RETURN
81041       END
81042  
81043 C*********************************************************************
81044  
81045 C...UPINIT
81046 C...Dummy routine, to be replaced by a user implementing external
81047 C...processes. Is supposed to fill the HEPRUP commonblock with info
81048 C...on incoming beams and allowed processes.
81049 
81050 C...New example: handles a standard Les Houches Events File.
81051 
81052       SUBROUTINE UPINIT
81053  
81054 C...Double precision and integer declarations.
81055       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81056       IMPLICIT INTEGER(I-N)
81057  
81058 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
81059       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81060       SAVE /PYPARS/
81061  
81062 C...User process initialization commonblock.
81063       INTEGER MAXPUP
81064       PARAMETER (MAXPUP=100)
81065       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
81066       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
81067       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
81068      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
81069      &LPRUP(MAXPUP)
81070       SAVE /HEPRUP/
81071 
81072 C...Lines to read in assumed never longer than 200 characters. 
81073       PARAMETER (MAXLEN=200)
81074       CHARACTER*(MAXLEN) STRING
81075 
81076 C...Format for reading lines.
81077       CHARACTER*6 STRFMT
81078       STRFMT='(A000)'
81079       WRITE(STRFMT(3:5),'(I3)') MAXLEN
81080 
81081 C...Loop until finds line beginning with "<init>" or "<init ". 
81082   100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
81083       IBEG=0
81084   110 IBEG=IBEG+1
81085 C...Allow indentation.
81086       IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110 
81087       IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
81088      &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
81089 
81090 C...Read first line of initialization info.
81091       READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
81092      &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
81093 
81094 C...Read NPRUP subsequent lines with information on each process.
81095       DO 120 IPR=1,NPRUP
81096         READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
81097      &  XMAXUP(IPR),LPRUP(IPR)
81098   120 CONTINUE
81099       RETURN
81100 
81101 C...Error exit: give up if initalization does not work.
81102   130 WRITE(*,*) ' Failed to read LHEF initialization information.'
81103       WRITE(*,*) ' Event generation will be stopped.'
81104       CALL PYSTOP(12)
81105  
81106       RETURN
81107       END
81108 
81109 C...Old example: handles a simple Pythia 6.4 initialization file.
81110  
81111 c      SUBROUTINE UPINIT
81112  
81113 C...Double precision and integer declarations.
81114 c      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81115 c      IMPLICIT INTEGER(I-N)
81116  
81117 C...Commonblocks.
81118 c      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81119 c      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81120 c      SAVE /PYDAT1/,/PYPARS/
81121  
81122 C...User process initialization commonblock.
81123 c      INTEGER MAXPUP
81124 c      PARAMETER (MAXPUP=100)
81125 c      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
81126 c      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
81127 c      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
81128 c     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
81129 c     &LPRUP(MAXPUP)
81130 c      SAVE /HEPRUP/
81131  
81132 C...Read info from file.
81133 c      IF(MSTP(161).GT.0) THEN
81134 c        READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
81135 c     &  EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
81136 c        DO 100 IPR=1,NPRUP
81137 c          READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
81138 c     &    XMAXUP(IPR),LPRUP(IPR)
81139 c  100   CONTINUE
81140 c        RETURN
81141 C...Error or prematurely reached end of file.
81142 c  110   WRITE(MSTU(11),5000)
81143 c        STOP
81144  
81145 C...Else not implemented.
81146 c      ELSE
81147 c        WRITE(MSTU(11),5100)
81148 c        STOP
81149 c      ENDIF
81150  
81151 C...Format for error printout.
81152 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
81153 c     &1X,'Execution stopped!')
81154 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
81155 c     &1X,'Dummy routine in PYTHIA file called instead.'/
81156 c     &1X,'Execution stopped!')
81157  
81158 c      RETURN
81159 c      END
81160  
81161 C*********************************************************************
81162  
81163 C...UPEVNT
81164 C...Dummy routine, to be replaced by a user implementing external
81165 C...processes. Depending on cross section model chosen, it either has
81166 C...to generate a process of the type IDPRUP requested, or pick a type
81167 C...itself and generate this event. The event is to be stored in the
81168 C...HEPEUP commonblock, including (often) an event weight.
81169 
81170 C...New example: handles a standard Les Houches Events File.
81171 
81172       SUBROUTINE UPEVNT
81173  
81174 C...Double precision and integer declarations.
81175       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81176       IMPLICIT INTEGER(I-N)
81177  
81178 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
81179       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81180       SAVE /PYPARS/
81181  
81182 C...User process event common block.
81183       INTEGER MAXNUP
81184       PARAMETER (MAXNUP=500)
81185       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
81186       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
81187       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
81188      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
81189      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
81190       SAVE /HEPEUP/
81191 
81192 C...Lines to read in assumed never longer than 200 characters. 
81193       PARAMETER (MAXLEN=200)
81194       CHARACTER*(MAXLEN) STRING
81195 
81196 C...Format for reading lines.
81197       CHARACTER*6 STRFMT
81198       STRFMT='(A000)'
81199       WRITE(STRFMT(3:5),'(I3)') MAXLEN
81200 
81201 C...Loop until finds line beginning with "<event>" or "<event ". 
81202   100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
81203       IBEG=0
81204   110 IBEG=IBEG+1
81205 C...Allow indentation.
81206       IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110 
81207       IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
81208      &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
81209 
81210 C...Read first line of event info.
81211       READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
81212      &AQEDUP,AQCDUP
81213 
81214 C...Read NUP subsequent lines with information on each particle.
81215       DO 120 I=1,NUP
81216         READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
81217      &  MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
81218      &  (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
81219   120 CONTINUE
81220       RETURN
81221 
81222 C...Error exit, typically when no more events.
81223   130 WRITE(*,*) ' Failed to read LHEF event information.'
81224       WRITE(*,*) ' Will assume end of file has been reached.'
81225       NUP=0
81226       MSTI(51)=1
81227  
81228       RETURN
81229       END
81230 
81231 C...Old example: handles a simple Pythia 6.4 event file.
81232  
81233 c      SUBROUTINE UPEVNT
81234  
81235 C...Double precision and integer declarations.
81236 c      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81237 c      IMPLICIT INTEGER(I-N)
81238  
81239 C...Commonblocks.
81240 c      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81241 c      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81242 c      SAVE /PYDAT1/,/PYPARS/
81243  
81244 C...User process event common block.
81245 c      INTEGER MAXNUP
81246 c      PARAMETER (MAXNUP=500)
81247 c      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
81248 c      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
81249 c      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
81250 c     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
81251 c     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
81252 c      SAVE /HEPEUP/
81253  
81254 C...Read info from file.
81255 c      IF(MSTP(162).GT.0) THEN
81256 c        READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
81257 c     &  AQEDUP,AQCDUP
81258 c        DO 100 I=1,NUP
81259 c          READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
81260 c     &    MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
81261 c     &    (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
81262 c  100   CONTINUE
81263 c        RETURN
81264 C...Special when reached end of file or other error.
81265 c  110   NUP=0
81266  
81267 C...Else not implemented.
81268 c      ELSE
81269 c        WRITE(MSTU(11),5000)
81270 c        STOP
81271 c      ENDIF
81272  
81273 C...Format for error printout.
81274 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
81275 c     &1X,'Dummy routine in PYTHIA file called instead.'/
81276 c     &1X,'Execution stopped!')
81277  
81278 c      RETURN
81279 c      END
81280  
81281 C*********************************************************************
81282  
81283 C...UPVETO
81284 C...Dummy routine, to be replaced by user, to veto event generation
81285 C...on the parton level, after parton showers but before multiple
81286 C...interactions, beam remnants and hadronization is added.
81287 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
81288 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
81289 C...be undecayed at this stage; if decayed their decay products will
81290 C...have been allowed to shower.
81291  
81292 C...All partons at the end of the shower phase are stored in the
81293 C...HEPEVT commonblock. The interesting information is
81294 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
81295 C...IDHEP(I) = the particle ID code according to PDG conventions,
81296 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
81297 C...All ISTHEP entries are 1, while the rest is zeroed.
81298  
81299 C...The user decision is to be conveyed by the IVETO value.
81300 C...IVETO = 0 : retain current event and generate in full;
81301 C...      = 1 : abort generation of current event and move to next.
81302  
81303       SUBROUTINE UPVETO(IVETO)
81304  
81305 C...HEPEVT commonblock.
81306       PARAMETER (NMXHEP=4000)
81307       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
81308      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
81309       DOUBLE PRECISION PHEP,VHEP
81310       SAVE /HEPEVT/
81311  
81312 C...Next few lines allow you to see what info PYVETO extracted from
81313 C...the full event record for the first two events.
81314 C...Delete if you don't want it.
81315       DATA NLIST/0/
81316       SAVE NLIST
81317       IF(NLIST.LE.2) THEN
81318         WRITE(*,*) ' Full event record at time of UPVETO call:'
81319         CALL PYLIST(1)
81320         WRITE(*,*) ' Part of event record made available to UPVETO:'
81321         CALL PYLIST(5)
81322         NLIST=NLIST+1
81323       ENDIF
81324  
81325 C...Make decision here.
81326       IVETO = 0
81327  
81328       RETURN
81329       END
81330  
81331 C*********************************************************************
81332  
81333 C...PDFSET
81334 C...Dummy routine, to be removed when PDFLIB is to be linked.
81335  
81336       SUBROUTINE PDFSETOLD(PARM,VALUE)
81337  
81338 C...Double precision and integer declarations.
81339       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81340       IMPLICIT INTEGER(I-N)
81341       INTEGER PYK,PYCHGE,PYCOMP
81342 C...Commonblocks.
81343       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81344       SAVE /PYDAT1/
81345 C...Local arrays and character variables.
81346       CHARACTER*20 PARM(20)
81347       DOUBLE PRECISION VALUE(20)
81348  
81349 C...Stop program if this routine is ever called.
81350       WRITE(MSTU(11),5000)
81351       CALL PYSTOP(5)
81352       PARM(20)=PARM(1)
81353       VALUE(20)=VALUE(1)
81354  
81355 C...Format for error printout.
81356  5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
81357      &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/
81358      &1X,'Execution stopped!')
81359  
81360       RETURN
81361       END
81362  
81363 C*********************************************************************
81364  
81365 C...STRUCTM
81366 C...Dummy routine, to be removed when PDFLIB is to be linked.
81367  
81368       SUBROUTINE STRUCTMOLD(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
81369  
81370 C...Double precision and integer declarations.
81371       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81372       IMPLICIT INTEGER(I-N)
81373       INTEGER PYK,PYCHGE,PYCOMP
81374 C...Commonblocks.
81375       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81376       SAVE /PYDAT1/
81377 C...Local variables
81378       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
81379  
81380 C...Stop program if this routine is ever called.
81381       WRITE(MSTU(11),5000)
81382       CALL PYSTOP(5)
81383       UPV=XX+QQ
81384       DNV=XX+2D0*QQ
81385       USEA=XX+3D0*QQ
81386       DSEA=XX+4D0*QQ
81387       STR=XX+5D0*QQ
81388       CHM=XX+6D0*QQ
81389       BOT=XX+7D0*QQ
81390       TOP=XX+8D0*QQ
81391       GLU=XX+9D0*QQ
81392  
81393 C...Format for error printout.
81394  5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
81395      &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/
81396      &1X,'Execution stopped!')
81397  
81398       RETURN
81399       END
81400  
81401 C*********************************************************************
81402  
81403 C...STRUCTP
81404 C...Dummy routine, to be removed when PDFLIB is to be linked.
81405  
81406       SUBROUTINE STRUCTPOLD(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
81407      &BOT,TOP,GLU)
81408  
81409 C...Double precision and integer declarations.
81410       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81411       IMPLICIT INTEGER(I-N)
81412       INTEGER PYK,PYCHGE,PYCOMP
81413 C...Commonblocks.
81414       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81415       SAVE /PYDAT1/
81416 C...Local variables
81417       DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
81418      &TOP,GLU
81419  
81420 C...Stop program if this routine is ever called.
81421       WRITE(MSTU(11),5000)
81422       CALL PYSTOP(5)
81423       UPV=XX+QQ2
81424       DNV=XX+2D0*QQ2
81425       USEA=XX+3D0*QQ2
81426       DSEA=XX+4D0*QQ2
81427       STR=XX+5D0*QQ2
81428       CHM=XX+6D0*QQ2
81429       BOT=XX+7D0*QQ2
81430       TOP=XX+8D0*QQ2
81431       GLU=XX+9D0*QQ2
81432  
81433 C...Format for error printout.
81434  5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
81435      &1X,'Dummy routine STRUCTP in PYTHIA file called instead.'/
81436      &1X,'Execution stopped!')
81437  
81438       RETURN
81439       END
81440  
81441 C*********************************************************************
81442  
81443 C...SUGRA
81444 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
81445  
81446       SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
81447        IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81448       IMPLICIT INTEGER(I-N)
81449       REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
81450       INTEGER IMODL
81451 C...Commonblocks.
81452       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81453       SAVE /PYDAT1/
81454  
81455 C...Stop program if this routine is ever called.
81456       WRITE(MSTU(11),5000)
81457       CALL PYSTOP(110)
81458  
81459 C...Format for error printout.
81460  5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
81461      &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
81462      &1X,'Execution stopped!')
81463  
81464       RETURN
81465       END
81466  
81467 C*********************************************************************
81468  
81469 C...VISAJE
81470 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
81471  
81472       FUNCTION VISAJE()
81473       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81474       IMPLICIT INTEGER(I-N)
81475       CHARACTER*40 VISAJE
81476  
81477 C...Commonblocks.
81478       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81479       SAVE /PYDAT1/
81480  
81481 C...Assign default value.
81482       VISAJE='Undefined'
81483  
81484 C...Stop program if this routine is ever called.
81485       WRITE(MSTU(11),5000)
81486       CALL PYSTOP(110)
81487  
81488 C...Format for error printout.
81489  5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
81490      &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
81491      &1X,'Execution stopped!')
81492  
81493       RETURN
81494       END
81495  
81496 C*********************************************************************
81497  
81498 C...SSMSSM
81499 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
81500  
81501       SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
81502      &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
81503      &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
81504      &IDUM1,IDUM2)
81505       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81506       IMPLICIT INTEGER(I-N)
81507       REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
81508      &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
81509      &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
81510 C...Commonblocks.
81511       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81512       SAVE /PYDAT1/
81513  
81514 C...Stop program if this routine is ever called.
81515       WRITE(MSTU(11),5000)
81516       CALL PYSTOP(110)
81517  
81518 C...Format for error printout.
81519  5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
81520      &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
81521      &1X,'Execution stopped!')
81522       RETURN
81523       END
81524  
81525 C*********************************************************************
81526  
81527 C...FHSETFLAGS
81528 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81529  
81530       SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
81531       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81532       IMPLICIT INTEGER(I-N)
81533 Cmssmpart = 4     # full MSSM [recommended]
81534 Cfieldren = 0     # MSbar field ren. [strongly recommended]
81535 Ctanbren =  0     # MSbar TB-ren. [strongly recommended]
81536 Chiggsmix = 2     # 2x2 (h0-HH) mixing in the neutral Higgs sector
81537 Cp2approx = 0     # no approximation [recommended]
81538 Clooplevel= 2     # include 2-loop corrections
81539 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
81540 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
81541  
81542 C...Commonblocks.
81543       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81544       SAVE /PYDAT1/
81545  
81546 C...Stop program if this routine is ever called.
81547       WRITE(MSTU(11),5000)
81548       CALL PYSTOP(103)
81549  
81550 C...Format for error printout.
81551  5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
81552      &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
81553      &1X,'Execution stopped!')
81554       RETURN
81555       END
81556  
81557 C*********************************************************************
81558  
81559 C...FHSETPARA
81560 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81561  
81562       SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
81563      &     DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
81564      &     DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
81565      &     DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
81566       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81567       IMPLICIT INTEGER(I-N)
81568  
81569       DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
81570       DOUBLE COMPLEX DMU,
81571      &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
81572      &     DM1, DM2, DM3
81573 
81574 C...Commonblocks.
81575       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81576       SAVE /PYDAT1/
81577  
81578 C...Stop program if this routine is ever called.
81579       WRITE(MSTU(11),5000)
81580       CALL PYSTOP(103)
81581  
81582 C...Format for error printout.
81583  5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
81584      &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
81585      &1X,'Execution stopped!')
81586       RETURN
81587       END
81588  
81589 C*********************************************************************
81590  
81591 C...FHHIGGSCORR
81592 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81593  
81594       SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
81595       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81596       IMPLICIT INTEGER(I-N)
81597  
81598 C...FeynHiggs variables
81599       DOUBLE PRECISION RMHIGG(4)
81600       DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
81601       DOUBLE COMPLEX DMU,
81602      &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
81603      &     DM1, DM2, DM3
81604 
81605 C...Commonblocks.
81606       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81607       SAVE /PYDAT1/
81608  
81609 C...Stop program if this routine is ever called.
81610       WRITE(MSTU(11),5000)
81611       CALL PYSTOP(103)
81612  
81613 C...Format for error printout.
81614  5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
81615      &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
81616      &1X,'Execution stopped!')
81617       RETURN
81618       END
81619   
81620 C*********************************************************************
81621  
81622 C...PYTAUD
81623 C...Dummy routine, to be replaced by user, to handle the decay of a
81624 C...polarized tau lepton.
81625 C...Input:
81626 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
81627 C...IORIG is the position where the mother of the tau is stored;
81628 C...     is 0 when the mother is not stored.
81629 C...KFORIG is the flavour of the mother of the tau;
81630 C...     is 0 when the mother is not known.
81631 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
81632 C...     e.g. in B hadron semileptonic decays the W  propagator
81633 C...     is not explicitly stored but the W code is still unambiguous.
81634 C...Output:
81635 C...NDECAY is the number of decay products in the current tau decay.
81636 C...These decay products should be added to the /PYJETS/ common block,
81637 C...in positions N+1 through N+NDECAY. For each product I you must
81638 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
81639 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
81640  
81641       SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
81642  
81643 C...Double precision and integer declarations.
81644       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81645       IMPLICIT INTEGER(I-N)
81646       INTEGER PYK,PYCHGE,PYCOMP
81647 C...Commonblocks.
81648       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
81649       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81650       SAVE /PYJETS/,/PYDAT1/
81651  
81652 C...Stop program if this routine is ever called.
81653 C...You should not copy these lines to your own routine.
81654       NDECAY=ITAU+IORIG+KFORIG
81655       WRITE(MSTU(11),5000)
81656       CALL PYSTOP(10)
81657  
81658 C...Format for error printout.
81659  5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
81660      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
81661      &1X,'Execution stopped!')
81662  
81663       RETURN
81664       END
81665  
81666 C*********************************************************************
81667  
81668 C...PYTIME
81669 C...Finds current date and time.
81670 C...Since this task is not standardized in Fortran 77, the routine
81671 C...is dummy, to be replaced by the user. Examples are given for
81672 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
81673 C...you do not have access to suitable routines.
81674  
81675       SUBROUTINE PYTIME(IDATI)
81676  
81677 C...Double precision and integer declarations.
81678       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81679       IMPLICIT INTEGER(I-N)
81680       INTEGER PYK,PYCHGE,PYCOMP
81681       CHARACTER*8 ATIME
81682 C...Local array.
81683       INTEGER IDATI(6),IDTEMP(3),IVAL(8)
81684  
81685 C...Example 0: if you do not have suitable routines.
81686       DO 100 J=1,6
81687       IDATI(J)=0
81688   100 CONTINUE
81689  
81690 C...Example 1: Fortran 90 routine.
81691 C      CALL DATE_AND_TIME(VALUES=IVAL)
81692 C      IDATI(1)=IVAL(1)
81693 C      IDATI(2)=IVAL(2)
81694 C      IDATI(3)=IVAL(3)
81695 C      IDATI(4)=IVAL(5)
81696 C      IDATI(5)=IVAL(6)
81697 C      IDATI(6)=IVAL(7)
81698  
81699 C...Example 2: DEC Fortran 77. AIX.
81700 C      CALL IDATE(IMON,IDAY,IYEAR)
81701 C      IDATI(1)=IYEAR
81702 C      IDATI(2)=IMON
81703 C      IDATI(3)=IDAY
81704 C      CALL ITIME(IHOUR,IMIN,ISEC)
81705 C      IDATI(4)=IHOUR
81706 C      IDATI(5)=IMIN
81707 C      IDATI(6)=ISEC
81708  
81709 C...Example 3: DEC Fortran, IRIX, IRIX64.
81710 C      CALL IDATE(IMON,IDAY,IYEAR)
81711 C      IDATI(1)=IYEAR
81712 C      IDATI(2)=IMON
81713 C      IDATI(3)=IDAY
81714 C      CALL TIME(ATIME)
81715 C      IHOUR=0
81716 C      IMIN=0
81717 C      ISEC=0
81718 C      READ(ATIME(1:2),'(I2)') IHOUR
81719 C      READ(ATIME(4:5),'(I2)') IMIN
81720 C      READ(ATIME(7:8),'(I2)') ISEC
81721 C      IDATI(4)=IHOUR
81722 C      IDATI(5)=IMIN
81723 C      IDATI(6)=ISEC
81724  
81725 C...Example 4: GNU LINUX libU77, SunOS.
81726 C      CALL IDATE(IDTEMP)
81727 C      IDATI(1)=IDTEMP(3)
81728 C      IDATI(2)=IDTEMP(2)
81729 C      IDATI(3)=IDTEMP(1)
81730 C      CALL ITIME(IDTEMP)
81731 C      IDATI(4)=IDTEMP(1)
81732 C      IDATI(5)=IDTEMP(2)
81733 C      IDATI(6)=IDTEMP(3)
81734  
81735 C...Common code to ensure right century.
81736       IDATI(1)=2000+MOD(IDATI(1),100)
81737  
81738       RETURN
81739       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated by the 2.3.7 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!