PYTHIA6/pythia6203.f

   1 C*********************************************************************
   2 C*********************************************************************
   3 C*                                                                  **
   4 C*                                                   August 2001    **
   5 C*                                                                  **
   6 C*                       The Lund Monte Carlo                       **
   7 C*                                                                  **
   8 C*                        PYTHIA version 6.2                        **
   9 C*                                                                  **
  10 C*                        Torbjorn Sjostrand                        **
  11 C*                 Department of Theoretical Physics                **
  12 C*                         Lund University                          **
  13 C*               Solvegatan 14A, S-223 62 Lund, Sweden              **
  14 C*                    phone +46 - 46 - 222 48 16                    **
  15 C*                    E-mail torbjorn@thep.lu.se                    **
  16 C*                                                                  **
  17 C*                  SUSY and Technicolor parts by                   **
  18 C*                         Stephen Mrenna                           **
  19 C*                   Physics Department, UC Davis                   **
  20 C*             One Shields Avenue, Davis, CA 95616, USA             **
  21 C*                   phone + 1 - 530 - 752 - 2661                   **
  22 C*                E-mail mrenna@physics.ucdavis.edu                 **
  23 C*                                                                  **
  24 C*                  PYTHIA 7 efforts coordinated by                 **
  25 C*                          Leif Lonnblad                           **
  26 C*                 Department of Theoretical Physics                **
  27 C*                         Lund University                          **
  28 C*               Solvegatan 14A, S-223 62 Lund, Sweden              **
  29 C*                    phone +46 - 46 - 222 77 80                    **
  30 C*                      E-mail leif@thep.lu.se                      **
  31 C*                                                                  **
  32 C*         Several parts are written by Hans-Uno Bengtsson          **
  33 C*          PYSHOW is written together with Mats Bengtsson          **
  34 C*               PYMAEL is written by Emanuel Norrbin               **
  35 C*     advanced popcorn baryon production written by Patrik Eden    **
  36 C*    code for virtual photons mainly written by Christer Friberg   **
  37 C*    code for low-mass strings mainly written by Emanuel Norrbin   **
  38 C*        Bose-Einstein code mainly written by Leif Lonnblad        **
  39 C*           Lepton number violation code by Peter Skands           **
  40 C*      CTEQ  parton distributions are by the CTEQ collaboration    **
  41 C*      GRV 94 parton distributions are by Glueck, Reya and Vogt    **
  42 C*   SaS photon parton distributions together with Gerhard Schuler  **
  43 C*     g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt     **
  44 C*         MSSM Higgs mass calculation code by M. Carena,           **
  45 C*           J.R. Espinosa, M. Quiros and C.E.M. Wagner             **
  46 C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **
  47 C*                                                                  **
  48 C*   The latest program version and documentation is found on WWW   **
  49 C*            http://www.thep.lu.se/~torbjorn/Pythia.html           **
  50 C*                                                                  **
  51 C*              Copyright Torbjorn Sjostrand, Lund 2001             **
  52 C*                                                                  **
  53 C*********************************************************************
  54 C*********************************************************************
  55 C                                                                    *
  56 C  List of subprograms in order of appearance, with main purpose     *
  57 C  (S = subroutine, F = function, B = block data)                    *
  58 C                                                                    *
  59 C  B   PYDATA   to contain all default values                        *
  60 C  S   PYTEST   to test the proper functioning of the package        *
  61 C  S   PYHEPC   to convert between /PYJETS/ and /HEPEVT/ records     *
  62 C                                                                    *
  63 C  S   PYINIT   to administer the initialization procedure           *
  64 C  S   PYEVNT   to administer the generation of an event             *
  65 C  S   PYSTAT   to print cross-section and other information         *
  66 C  S   PYINRE   to initialize treatment of resonances                *
  67 C  S   PYINBM   to read in beam, target and frame choices            *
  68 C  S   PYINKI   to initialize kinematics of incoming particles       *
  69 C  S   PYINPR   to set up the selection of included processes        *
  70 C  S   PYXTOT   to give total, elastic and diffractive cross-sect.   *
  71 C  S   PYMAXI   to find differential cross-section maxima            *
  72 C  S   PYPILE   to select multiplicity of pileup events              *
  73 C  S   PYSAVE   to save alternatives for gamma-p and gamma-gamma     *
  74 C  S   PYGAGA   to handle lepton -> lepton + gamma branchings        *
  75 C  S   PYRAND   to select subprocess and kinematics for event        *
  76 C  S   PYSCAT   to set up kinematics and colour flow of event        *
  77 C  S   PYSSPA   to simulate initial state spacelike showers          *
  78 C  S   PYMEMX   auxiliary to PYSSPA for ME correction maximum        *
  79 C  S   PYMEWT   auxiliary to PYSSPA for matrix element correction    *
  80 C  S   PYADSH   to administrate sequential final-state showers       *
  81 C  S   PYRESD   to perform resonance decays                          *
  82 C  S   PYMULT   to generate multiple interactions                    *
  83 C  S   PYREMN   to add on target remnants                            *
  84 C  S   PYDIFF   to set up kinematics for diffractive events          *
  85 C  S   PYDISG   to set up kinematics, remnant and showers for DIS    *
  86 C  S   PYDOCU   to compute cross-sections and handle documentation   *
  87 C  S   PYFRAM   to perform boosts between different frames           *
  88 C  S   PYWIDT   to calculate full and partial widths of resonances   *
  89 C  S   PYOFSH   to calculate partial width into off-shell channels   *
  90 C  S   PYRECO   to handle colour reconnection in W+W- events         *
  91 C  S   PYKLIM   to calculate borders of allowed kinematical region   *
  92 C  S   PYKMAP   to construct value of kinematical variable           *
  93 C  S   PYSIGH   to calculate differential cross-sections             *
  94 C  S   PYPDFU   to evaluate parton distributions                     *
  95 C  S   PYPDFL   to evaluate parton distributions at low x and Q^2    *
  96 C  S   PYPDEL   to evaluate electron parton distributions            *
  97 C  S   PYPDGA   to evaluate photon parton distributions (generic)    *
  98 C  S   PYGGAM   to evaluate photon parton distributions (SaS sets)   *
  99 C  S   PYGVMD   to evaluate VMD part of photon parton distributions  *
 100 C  S   PYGANO   to evaluate anomalous part of photon pdf's           *
 101 C  S   PYGBEH   to evaluate Bethe-Heitler part of photon pdf's       *
 102 C  S   PYGDIR   to evaluate direct contribution to photon pdf's      *
 103 C  S   PYPDPI   to evaluate pion parton distributions                *
 104 C  S   PYPDPR   to evaluate proton parton distributions              *
 105 C  F   PYCTEQ   to evaluate the CTEQ 3 proton parton distributions   *
 106 C  S   PYGRVL   to evaluate the GRV 94L proton parton distributions  *
 107 C  S   PYGRVM   to evaluate the GRV 94M proton parton distributions  *
 108 C  S   PYGRVD   to evaluate the GRV 94D proton parton distributions  *
 109 C  F   PYGRVV   auxiliary to the PYGRV* routines                     *
 110 C  F   PYGRVW   auxiliary to the PYGRV* routines                     *
 111 C  F   PYGRVS   auxiliary to the PYGRV* routines                     *
 112 C  F   PYCT5L   to evaluate the CTEQ 5L proton parton distributions  *
 113 C  F   PYCT5M   to evaluate the CTEQ 5M1 proton parton distributions *
 114 C  S   PYPDPO   to evaluate old proton parton distributions          *
 115 C  F   PYHFTH   to evaluate threshold factor for heavy flavour       *
 116 C  S   PYSPLI   to find flavours left in hadron when one removed     *
 117 C  F   PYGAMM   to evaluate ordinary Gamma function Gamma(x)         *
 118 C  S   PYWAUX   to evaluate auxiliary functions W1(s) and W2(s)      *
 119 C  S   PYI3AU   to evaluate auxiliary function I3(s,t,u,v)           *
 120 C  F   PYSPEN   to evaluate Spence (dilogarithm) function Sp(x)      *
 121 C  S   PYQQBH   to evaluate matrix element for g + g -> Q + Qbar + H *
 122 C                                                                    *
 123 C  S   PYMSIN   to initialize the supersymmetry simulation           *
 124 C  S   PYAPPS   to determine MSSM parameters from SUGRA input        *
 125 C  F   PYRNMQ   to determine running quark masses                    *
 126 C  F   PYRNMT   to determine running top mass                        *
 127 C  S   PYTHRG   to calculate sfermion third-gen. mass eigenstates    *
 128 C  S   PYINOM   to calculate neutralino/chargino mass eigenstates    *
 129 C  F   PYRNM3   to determine running M3, gluino mass                 *
 130 C  S   PYEIG4   to calculate eigenvalues and -vectors in 4*4 matrix  *
 131 C  S   PYHGGM   to determine Higgs mass spectrum                     *
 132 C  S   PYSUBH   to determine Higgs masses in the MSSM                *
 133 C  S   PYPOLE   to determine Higgs masses in the MSSM                *
 134 C  S   PYRGHM   auxiliary to PYPOLE                                  *
 135 C  S   PYGFXX   auxiliary to PYRGHM                                  *
 136 C  F   PYFINT   auxiliary to PYPOLE                                  *
 137 C  F   PYFISB   auxiliary to PYFINT                                  *
 138 C  S   PYSFDC   to calculate sfermion decay partial widths           *
 139 C  S   PYGLUI   to calculate gluino decay partial widths             *
 140 C  S   PYTBBN   to calculate 3-body decay of gluino to neutralino    *
 141 C  S   PYTBBC   to calculate 3-body decay of gluino to chargino      *
 142 C  S   PYNJDC   to calculate neutralino decay partial widths         *
 143 C  S   PYCJDC   to calculate chargino decay partial widths           *
 144 C  F   PYXXZ6   auxiliary for ino 3-body decays                      *
 145 C  F   PYXXGA   auxiliary for ino -> ino + gamma decay               *
 146 C  F   PYX2XG   auxiliary for ino -> ino + gauge boson decay         *
 147 C  F   PYX2XH   auxiliary for ino -> ino + Higgs decay               *
 148 C  S   PYHEXT   to calculate non-SM Higgs decay partial widths       *
 149 C  F   PYH2XX   auxiliary for H -> ino + ino decay                   *
 150 C  F   PYGAUS   to perform Gaussian integration                      *
 151 C  F   PYSIMP   to perform Simpson integration                       *
 152 C  F   PYLAMF   to evaluate the lambda kinematics function           *
 153 C  S   PYTBDY   to perform 3-body decay of gauginos                  *
 154 C  S   PYTECM   to calculate techni_rho/omega masses                 *
 155 C  S   PYEICG   to calculate eigenvalues of a 4*4 complex matrix     *
 156 C  S   PYCMQR   auxiliary to PYEICG                                  *
 157 C  S   PYCMQ2   auxiliary to PYEICG                                  *
 158 C  S   PYCDIV   auxiliary to PYCMQR                                  *
 159 C  S   PYCSRT   auxiliary to PYCMQR                                  *
 160 C  S   PYTHAG   auxiliary to PYCMQR                                  *
 161 C  S   PYCBAL   auxiliary to PYEICG                                  *
 162 C  S   PYCBA2   auxiliary to PYEICG                                  *
 163 C  S   PYCRTH   auxiliary to PYEICG                                  *
 164 C  S   PYLDCM   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
 165 C  S   PYBKSB   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
 166 C  S   PYWIDX   to calculate decay widths from within PYWIDT         *
 167 C  S   PYRVSF   to calculate R-violating sfermion decay widths       *
 168 C  S   PYRVNE   to calculate R-violating neutralino decay widths     *
 169 C  S   PYRVCH   to calculate R-violating chargino decay widths       *
 170 C  F   PYRVSB   auxiliary to PYRVSF                                  *
 171 C  S   PYRVGW   to calculate R-Violating 3-body widths               *
 172 C  F   PYRVI1   auxiliary to PYRVGW, to do PS integration for res.   *
 173 C  F   PYRVI2   auxiliary to PYRVGW, to do PS integration for LR-int.*
 174 C  F   PYRVI3   auxiliary to PYRVGW, to do PS X integral for int.    *
 175 C  F   PYRVG1   auxiliary to PYRVI1, general matrix element, res.    *
 176 C  F   PYRVG2   auxiliary to PYRVI2, general matrix element, LR-int. *
 177 C  F   PYRVG3   auxiliary to PYRVI3, to do PS Y integral for int.    *
 178 C  F   PYRVG4   auxiliary to PYRVG3, general matrix element, int.    *
 179 C  F   PYRVR    auxiliary to PYRVG1, Breit-Wigner                    *
 180 C  F   PYRVS    auxiliary to PYRVG2 & PYRVG4                         *
 181 C                                                                    *
 182 C  S   PY1ENT   to fill one entry (= parton or particle)             *
 183 C  S   PY2ENT   to fill two entries                                  *
 184 C  S   PY3ENT   to fill three entries                                *
 185 C  S   PY4ENT   to fill four entries                                 *
 186 C  S   PY2FRM   to interface to generic two-fermion generator        *
 187 C  S   PY4FRM   to interface to generic four-fermion generator       *
 188 C  S   PY6FRM   to interface to generic six-fermion generator        *
 189 C  S   PY4JET   to generate a shower from a given 4-parton config    *
 190 C  S   PY4JTW   to evaluate the weight od a shower history for above *
 191 C  S   PY4JTS   to set up the parton configuration for above         *
 192 C  S   PYJOIN   to connect entries with colour flow information      *
 193 C  S   PYGIVE   to fill (or query) commonblock variables             *
 194 C  S   PYEXEC   to administrate fragmentation and decay chain        *
 195 C  S   PYPREP   to rearrange showered partons along strings          *
 196 C  S   PYSTRF   to do string fragmentation of jet system             *
 197 C  S   PYINDF   to do independent fragmentation of one or many jets  *
 198 C  S   PYDECY   to do the decay of a particle                        *
 199 C  S   PYDCYK   to select parton and hadron flavours in decays       *
 200 C  S   PYKFDI   to select parton and hadron flavours in fragm        *
 201 C  S   PYNMES   to select number of popcorn mesons                   *
 202 C  S   PYKFIN   to calculate falvour prod. ratios from input params. *
 203 C  S   PYPTDI   to select transverse momenta in fragm                *
 204 C  S   PYZDIS   to select longitudinal scaling variable in fragm     *
 205 C  S   PYSHOW   to do timelike parton shower evolution               *
 206 C  F   PYMAEL   auxiliary to PYSHOW, with gluon emission ME's        *
 207 C  S   PYBOEI   to include Bose-Einstein effects (crudely)           *
 208 C  S   PYBESQ   auxiliary to PYBOEI                                  *
 209 C  F   PYMASS   to give the mass of a particle or parton             *
 210 C  F   PYMRUN   to give the running MSbar mass of a quark            *
 211 C  S   PYNAME   to give the name of a particle or parton             *
 212 C  F   PYCHGE   to give three times the electric charge              *
 213 C  F   PYCOMP   to compress standard KF flavour code to internal KC  *
 214 C  S   PYERRM   to write error messages and abort faulty run         *
 215 C  F   PYALEM   to give the alpha_electromagnetic value              *
 216 C  F   PYALPS   to give the alpha_strong value                       *
 217 C  F   PYANGL   to give the angle from known x and y components      *
 218 C  F   PYR      to provide a random number generator                 *
 219 C  S   PYRGET   to save the state of the random number generator     *
 220 C  S   PYRSET   to set the state of the random number generator      *
 221 C  S   PYROBO   to rotate and/or boost an event                      *
 222 C  S   PYEDIT   to remove unwanted entries from record               *
 223 C  S   PYLIST   to list event record or particle data                *
 224 C  S   PYLOGO   to write a logo                                      *
 225 C  S   PYUPDA   to update particle data                              *
 226 C  F   PYK      to provide integer-valued event information          *
 227 C  F   PYP      to provide real-valued event information             *
 228 C  S   PYSPHE   to perform sphericity analysis                       *
 229 C  S   PYTHRU   to perform thrust analysis                           *
 230 C  S   PYCLUS   to perform three-dimensional cluster analysis        *
 231 C  S   PYCELL   to perform cluster analysis in (eta, phi, E_T)       *
 232 C  S   PYJMAS   to give high and low jet mass of event               *
 233 C  S   PYFOWO   to give Fox-Wolfram moments                          *
 234 C  S   PYTABU   to analyze events, with tabular output               *
 235 C                                                                    *
 236 C  S   PYEEVT   to administrate the generation of an e+e- event      *
 237 C  S   PYXTEE   to give the total cross-section at given CM energy   *
 238 C  S   PYRADK   to generate initial state photon radiation           *
 239 C  S   PYXKFL   to select flavour of primary qqbar pair              *
 240 C  S   PYXJET   to select (matrix element) jet multiplicity          *
 241 C  S   PYX3JT   to select kinematics of three-jet event              *
 242 C  S   PYX4JT   to select kinematics of four-jet event               *
 243 C  S   PYXDIF   to select angular orientation of event               *
 244 C  S   PYONIA   to perform generation of onium decay to gluons       *
 245 C                                                                    *
 246 C  S   PYBOOK   to book a histogram                                  *
 247 C  S   PYFILL   to fill an entry in a histogram                      *
 248 C  S   PYFACT   to multiply histogram contents by a factor           *
 249 C  S   PYOPER   to perform operations between histograms             *
 250 C  S   PYHIST   to print and reset all histograms                    *
 251 C  S   PYPLOT   to print a single histogram                          *
 252 C  S   PYNULL   to reset contents of a single histogram              *
 253 C  S   PYDUMP   to dump histogram contents onto a file               *
 254 C                                                                    *
 255 C  S   PYKCUT   dummy routine for user kinematical cuts              *
 256 C  S   PYEVWT   dummy routine for weighting events                   *
 257 C  S   UPINIT   dummy routine to initialize user processes           *
 258 C  S   UPEVNT   dummy routine to generate a user process event       *
 259 C  S   PDFSET   dummy routine to be removed when using PDFLIB        *
 260 C  S   STRUCTM  dummy routine to be removed when using PDFLIB        *
 261 C  S   STRUCTP  dummy routine to be removed when using PDFLIB        *
 262 C  S   PYTAUD   dummy routine for interface to tau decay libraries   *
 263 C  S   PYTIME   dummy routine for giving date and time               *
 264 C                                                                    *
 265 C*********************************************************************
 266
 267 C...PYDATA
 268 C...Default values for switches and parameters,
 269 C...and particle, decay and process data.
 270
 271       BLOCK DATA PYDATA
 272
 273 C...Double precision and integer declarations.
 274       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
 275       IMPLICIT INTEGER(I-N)
 276       INTEGER PYK,PYCHGE,PYCOMP
 277 C...Commonblocks.
 278       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 279       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 280       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 281       COMMON/PYDAT4/CHAF(500,2)
 282       CHARACTER CHAF*16
 283       COMMON/PYDATR/MRPY(6),RRPY(100)
 284       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
 285       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
 286       COMMON/PYINT1/MINT(400),VINT(400)
 287       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
 288       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
 289       COMMON/PYINT4/MWID(500),WIDS(500,5)
 290       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
 291       COMMON/PYINT6/PROC(0:500)
 292       CHARACTER PROC*28
 293       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
 294       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
 295       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
 296      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
 297       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
 298       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
 299       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
 300      &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
 301      &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYBINS/
 302
 303 C...PYDAT1, containing status codes and most parameters.
 304       DATA MSTU/
 305      &   0,    0,    0, 4000,10000,  500, 8000,    0,    0,    2,
 306      1   6,    1,    1,    0,    0,    1,    0,    0,    0,    0,
 307      2   2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
 308      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 309      4   2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
 310      5  25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
 311      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 312      7  30*0,
 313      1   1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 314      2   1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
 315      &  80*0/
 316       DATA (PARU(I),I=1,100)/
 317      &  3.141592653589793D0, 6.283185307179586D0,
 318      &  0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0,  4*0D0,
 319      1  0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
 320      2  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
 321      3  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
 322      4  2.0D0,  1.0D0, 0.25D0,  2.5D0, 0.05D0,
 323      4  0D0,   0D0, 0.0001D0, 0D0,   0D0,
 324      5  2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
 325      6  40*0D0/
 326       DATA (PARU(I),I=101,200)/
 327      &  0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
 328      &  0D0, 0D0, 0D0, 0D0,  0D0,
 329      1  0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0,  0D0, 0D0, 0D0,
 330      2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
 331      2 -1.0D0,  1.0D0,  1.0D0,  1.0D0,  0D0,
 332      3  1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 333      4  5.0D0, 1.0D0, 1.0D0,  0D0, 1.0D0, 1.0D0,  0D0, 0D0, 0D0, 0D0,
 334      5  1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
 335      6  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 336      7  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
 337      8  1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
 338      9  0D0,  0D0,  0D0,  0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0/
 339       DATA MSTJ/
 340      &  1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
 341      1  4,    2,    0,    1,    0,    2,    2,    0,    0,    0,
 342      2  2,    1,    1,    2,    1,    2,    2,    0,    0,    0,
 343      3  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 344      4  2,    2,    4,    2,    5,    3,    3,    0,    0,    3,
 345      5  0,    3,    0,    2,    0,    0,    1,    0,    0,    0,
 346      6  40*0,
 347      &  5,    2,    7,    5,    1,    1,    0,    2,    0,    2,
 348      1  0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
 349      2  80*0/
 350       DATA PARJ/
 351      &  0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
 352      &  0.50D0, 0.50D0,   0.6D0,   1.2D0,   0.6D0,
 353      1  0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
 354      2  0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
 355      3  0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0,
 356      4  0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0, 0D0, 0D0,0D0,
 357      5  0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
 358      5  0D0, 0D0, 0D0, 1.0D0, 0D0,
 359      6  4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
 360      7  10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
 361      8  0.29D0, 1.0D0, 1.0D0,  0D0,  10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
 362      9  0.02D0, 1.0D0, 0.2D0,  0D0,  0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 363      &  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
 364      1  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
 365      2  1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
 366      2  2.0D0,  1.0D0, 0.25D0,0.002D0,   0D0,
 367      3  0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0,  0.2D0,   0D0,
 368      4  10*0D0,
 369      5  10*0D0,
 370      6  10*0D0,
 371      7  0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
 372      8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
 373      8  1.0D0,  1.0D0, -0.693D0, -1.0D0, 0.387D0,
 374      9  1.0D0, -0.08D0, -1.0D0,   1.0D0, 1.0D0,
 375      9  5*0D0/
 376
 377 C...PYDAT2, with particle data and flavour treatment parameters.
 378       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
 379      &-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,
 380      &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,
 381      &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,
 382      &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,
 383      &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,
 384      &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,
 385      &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,
 386      &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,
 387      &139*0/
 388       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
 389      &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,
 390      &-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,
 391      &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
 392       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
 393      &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,
 394      &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,
 395      &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/
 396       DATA (KCHG(I,4),I=   1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
 397      &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
 398      &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
 399      &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
 400      &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
 401      &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
 402      &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
 403      &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
 404      &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
 405      &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
 406      &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
 407      &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
 408      &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
 409      &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
 410      &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
 411      &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
 412      &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
 413      &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
 414      &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
 415      &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
 416       DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
 417      &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
 418      &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
 419      &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
 420      &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
 421      &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
 422      &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
 423      &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
 424      &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
 425      &9902110,9902210,139*0/
 426       DATA (PMAS(I,1),I=   1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
 427      &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
 428      &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
 429      &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
 430      &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
 431      &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
 432      &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
 433      &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
 434      &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
 435      &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
 436      &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
 437      &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
 438      &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
 439      &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
 440      &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
 441      &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
 442      &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
 443      &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
 444      &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
 445      &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
 446       DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
 447      &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
 448      &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
 449      &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
 450      &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
 451      &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
 452      &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
 453      &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
 454      &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
 455      &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
 456      &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
 457      &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
 458      &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
 459       DATA (PMAS(I,2),I=   1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
 460      &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
 461      &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
 462      &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
 463      &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
 464      &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
 465      &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
 466      &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
 467      &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
 468      &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
 469      &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
 470      &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
 471      &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
 472      &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
 473      &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
 474      &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
 475      &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
 476      &7*0D0,139*0D0/
 477       DATA (PMAS(I,3),I=   1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
 478      &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
 479      &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
 480      &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
 481      &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
 482      &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
 483      &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
 484      &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
 485      &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
 486      &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
 487      &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
 488      &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
 489      &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
 490      &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
 491      &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
 492      &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
 493      &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
 494      &8.80013D0,7*0D0,139*0D0/
 495       DATA (PMAS(I,4),I=   1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
 496      &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
 497      &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
 498      &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
 499      &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
 500      &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
 501      &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
 502      &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
 503       DATA PARF/
 504      &  0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0,  0D0,  0D0,  0D0, 0D0,
 505      1  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 506      2  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 507      3  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 508      4  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 509      5  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 510      6  0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
 511      7  0D0,  0D0,  1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
 512      8  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 513      9  0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 165D0,  4*0D0,
 514      & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 515      1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
 516      2 0.2D0, 0.1D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 517      3 60*0D0,
 518      4 0.2D0,  0.5D0,  8*0D0,
 519      5 1800*0D0/
 520       DATA ((VCKM(I,J),J=1,4),I=1,4)/
 521      &  0.95113D0,  0.04884D0,  0.00003D0,  0.00000D0,
 522      &  0.04884D0,  0.94940D0,  0.00176D0,  0.00000D0,
 523      &  0.00003D0,  0.00176D0,  0.99821D0,  0.00000D0,
 524      &  0.00000D0,  0.00000D0,  0.00000D0,  1.00000D0/
 525
 526 C...PYDAT3, with particle decay parameters and data.
 527       DATA (MDCY(I,1),I=   1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
 528      &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,
 529      &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,
 530      &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,146*0/
 531       DATA (MDCY(I,2),I=   1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
 532      &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
 533      &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
 534      &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
 535      &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
 536      &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
 537      &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
 538      &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
 539      &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
 540      &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
 541      &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
 542      &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
 543      &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
 544      &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
 545      &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
 546      &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
 547      &1631,1652,1691,1712,1751,1775,1806,1832,1864,1890,1922,1948,2009,
 548      &2160,2406,2615,2877,3155,0,3388,3431,3456,3499,3524,3567,3592,0,
 549      &3628,0,3664,0,3700,3708,3716,3724,3727,3751,3777,3801,3807,3814,
 550      &3821,3828,3834,3840,3849,3853,3857,3860,3862,3883,3905,3927,3949/
 551       DATA (MDCY(I,2),I= 352, 500)/3964,3976,3983,146*0/
 552       DATA (MDCY(I,3),I=   1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
 553      &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,
 554      &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,
 555      &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,
 556      &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,
 557      &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,
 558      &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,39,21,39,21,
 559      &39,24,31,26,32,26,32,26,61,151,246,209,262,278,233,0,43,25,43,25,
 560      &43,25,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,21,3*22,
 561      &15,12,2*7,146*0/
 562       DATA (MDME(I,1),I=   1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
 563      &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,
 564      &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,
 565      &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,
 566      &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,
 567      &3*1,-1,3*1,-1,1,18*-1,4*1,2*-1,2*1,-1,1225*1,2*-1,248*1,2*-1,
 568      &1725*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,5*-1,3*1,-1,14*1,2*-1,6*1,
 569      &2*-1,67*1,2*-1,6*1,2*-1,4*1,-1,107*1,4011*0/
 570       DATA (MDME(I,2),I=   1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
 571      &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
 572      &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
 573      &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
 574      &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,
 575      &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,
 576      &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,
 577      &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
 578      &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,
 579      &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,
 580      &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,
 581      &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,
 582      &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2108*53,4*32,
 583      &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
 584      &46*32,3*53,12*0,8*32,13*0,66*51,6*32,9*0,9*32,4028*0/
 585       DATA (BRAT(I)  ,I=   1, 346)/43*0D0,0.00003D0,0.001765D0,
 586      &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
 587      &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
 588      &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
 589      &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
 590      &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
 591      &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
 592      &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
 593      &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
 594      &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
 595      &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
 596      &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
 597      &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
 598      &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
 599      &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
 600      &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
 601      &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
 602      &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
 603      &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
 604      &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
 605       DATA (BRAT(I)  ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
 606      &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
 607      &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
 608      &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
 609      &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
 610      &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
 611      &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
 612      &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
 613      &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
 614      &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
 615      &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
 616      &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
 617      &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
 618      &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
 619      &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
 620      &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
 621      &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
 622      &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
 623      &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
 624      &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
 625       DATA (BRAT(I)  ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
 626      &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
 627      &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
 628      &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
 629      &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
 630      &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
 631      &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
 632      &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
 633      &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
 634      &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
 635      &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
 636      &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
 637      &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
 638      &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
 639      &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
 640      &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
 641      &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
 642      &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
 643      &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
 644      &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
 645       DATA (BRAT(I)  ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
 646      &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
 647      &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
 648      &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
 649      &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
 650      &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
 651      &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
 652      &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
 653      &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
 654      &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
 655      &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
 656      &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
 657      &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
 658      &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
 659      &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
 660      &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
 661      &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
 662      &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
 663      &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
 664      &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
 665       DATA (BRAT(I)  ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
 666      &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
 667      &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
 668      &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
 669      &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
 670      &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
 671      &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
 672      &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
 673      &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
 674      &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
 675      &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
 676      &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
 677      &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
 678      &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
 679      &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
 680      &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
 681      &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
 682      &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
 683      &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
 684      &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
 685       DATA (BRAT(I)  ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
 686      &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
 687      &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
 688      &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
 689      &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
 690      &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
 691      &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
 692      &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
 693      &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
 694      &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 695      &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 696      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 697      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 698      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 699      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 700      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 701      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 702      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 703      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 704      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
 705       DATA (BRAT(I)  ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
 706      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 707      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 708      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 709      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 710      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 711      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 712      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 713      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
 714      &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
 715      &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
 716      &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
 717      &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
 718      &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
 719      &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
 720      &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
 721      &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
 722      &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
 723      &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
 724      &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
 725       DATA (BRAT(I)  ,I=1581,3853)/0.008D0,0.024D0,0.008D0,0.024D0,
 726      &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2108*0D0,
 727      &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
 728      &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
 729      &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
 730      &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
 731      &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
 732      &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
 733      &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
 734      &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
 735      &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
 736      &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
 737      &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
 738      &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
 739      &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
 740      &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
 741      &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
 742      &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
 743      &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
 744      &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
 745       DATA (BRAT(I)  ,I=3854,3984)/0.021617D0,0.030018D0,0.098466D0,
 746      &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
 747      &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
 748      &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0D0,0.19874D0,
 749      &0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
 750      &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
 751      &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
 752      &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
 753      &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
 754      &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
 755      &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,
 756      &0.010236D0,0.198928D0,0.000149D0,0.000006D0,0.000368D0,
 757      &0.080733D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
 758      &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,
 759      &0.184738D0,0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,
 760      &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
 761      &0.015602D0,0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,
 762      &0.000008D0,0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,
 763      &0.27911D0,2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,
 764      &0.090266D0,0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0/
 765       DATA (BRAT(I)  ,I=3985,8000)/0.001808D0,0.090428D0,0.001808D0,
 766      &0.81372D0,0D0,4011*0D0/
 767       DATA (KFDP(I,1),I=   1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
 768      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
 769      &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
 770      &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
 771      &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
 772      &-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,
 773      &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
 774      &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
 775      &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
 776      &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
 777      &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
 778      &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
 779      &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
 780      &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
 781      &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
 782      &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
 783      &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
 784      &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
 785      &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
 786      &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
 787       DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
 788      &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
 789      &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
 790      &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
 791      &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
 792      &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
 793      &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
 794      &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
 795      &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
 796      &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
 797      &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
 798      &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
 799      &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
 800      &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
 801      &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
 802      &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
 803      &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
 804      &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
 805      &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
 806      &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
 807       DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
 808      &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
 809      &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
 810      &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
 811      &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
 812      &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
 813      &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
 814      &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
 815      &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
 816      &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
 817      &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
 818      &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
 819      &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
 820      &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
 821      &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
 822      &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
 823      &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
 824      &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
 825      &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
 826      &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
 827       DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
 828      &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
 829      &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
 830      &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
 831      &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
 832      &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
 833      &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
 834      &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
 835      &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
 836      &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
 837      &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
 838      &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
 839      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
 840      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
 841      &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
 842      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
 843      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
 844      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
 845      &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
 846      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
 847       DATA (KFDP(I,1),I=1403,1708)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
 848      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
 849      &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
 850      &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
 851      &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
 852      &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
 853      &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
 854      &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
 855      &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
 856      &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
 857      &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
 858      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
 859      &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
 860      &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,1000039,1000024,
 861      &1000037,1000022,1000023,1000025,1000035,1000001,2000001,1000001,
 862      &2000001,1000021,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,
 863      &1000022,1000023,1000025,1000035,1000004,2000004,1000004,2000004,
 864      &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
 865      &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
 866      &1000035,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13/
 867       DATA (KFDP(I,1),I=1709,1966)/3*-15,1000039,-1000024,-1000037,
 868      &1000022,1000023,1000025,1000035,1000006,2000006,1000006,2000006,
 869      &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
 870      &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
 871      &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
 872      &-1000015,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,1000022,
 873      &1000023,1000025,1000035,1000012,2000012,1000012,2*12,2*14,2*16,
 874      &3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
 875      &1000023,1000025,1000035,1000011,2000011,1000011,2000011,3*-13,
 876      &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
 877      &1000025,1000035,1000014,2000014,1000014,2000014,2*12,2*14,2*16,
 878      &3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
 879      &1000023,1000025,1000035,1000013,2000013,1000013,2000013,3*-11,
 880      &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
 881      &1000025,1000035,1000016,2000016,1000016,2000016,2*12,2*14,2*16,
 882      &3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
 883      &1000023,1000025,1000035,1000015,2000015,1000015,2000015,3*-11,
 884      &3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,2000001,-2000001,
 885      &1000002,-1000002,2000002,-2000002,1000003,-1000003,2000003,
 886      &-2000003,1000004,-1000004,2000004,-2000004,1000005,-1000005/
 887       DATA (KFDP(I,1),I=1967,2235)/2000005,-2000005,1000006,-1000006,
 888      &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
 889      &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037,
 890      &1000037,-1000037,1000037,-1000037,5*1000039,4,1,-12,12,-12,12,
 891      &-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,
 892      &-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,
 893      &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
 894      &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
 895      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
 896      &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
 897      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
 898      &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,5*1000039,
 899      &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
 900      &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
 901      &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
 902      &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
 903      &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
 904      &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
 905      &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
 906      &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011/
 907       DATA (KFDP(I,1),I=2236,2523)/-2000011,1000012,-1000012,2000012,
 908      &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
 909      &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
 910      &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
 911      &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
 912      &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
 913      &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
 914      &-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,-13,13,
 915      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
 916      &-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,-15,15,
 917      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
 918      &-15,15,-16,16,-15,15,-16,16,-15,15,2*1000039,6*1000022,6*1000023,
 919      &6*1000025,6*1000035,1000022,1000023,1000025,1000035,1000002,
 920      &2000002,-1000001,-2000001,1000004,2000004,-1000003,-2000003,
 921      &1000006,2000006,-1000005,-2000005,1000012,2000012,-1000011,
 922      &-2000011,1000014,2000014,-1000013,-2000013,1000016,2000016,
 923      &-1000015,-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,
 924      &12,-11,-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,
 925      &-14,14,-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
 926      &-16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12/
 927       DATA (KFDP(I,1),I=2524,2794)/2*-11,12,-12,2*-11,12,-12,2*-11,12,
 928      &-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
 929      &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
 930      &-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
 931      &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
 932      &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
 933      &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
 934      &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
 935      &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
 936      &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
 937      &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
 938      &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
 939      &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
 940      &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
 941      &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
 942      &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
 943      &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
 944      &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
 945      &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
 946      &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12/
 947       DATA (KFDP(I,1),I=2795,3070)/-11,11,-12,12,-11,11,-12,12,-11,11,
 948      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
 949      &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
 950      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
 951      &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
 952      &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
 953      &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
 954      &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
 955      &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
 956      &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
 957      &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
 958      &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
 959      &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
 960      &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
 961      &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
 962      &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
 963      &1000016,-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,
 964      &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
 965      &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
 966      &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11/
 967       DATA (KFDP(I,1),I=3071,3398)/-12,12,-11,11,-12,12,-11,11,-12,12,
 968      &-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
 969      &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
 970      &-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
 971      &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
 972      &-15,15,2*1000039,15*1000024,6*1000022,6*1000023,6*1000025,
 973      &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
 974      &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
 975      &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
 976      &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
 977      &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
 978      &-12,12,-11,-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
 979      &-13,-14,14,-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,
 980      &16,-15,-16,16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
 981      &12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
 982      &12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
 983      &14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
 984      &14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,
 985      &16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,1000039,
 986      &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000001/
 987       DATA (KFDP(I,1),I=3399,3676)/1000002,2000002,1000002,2000002,
 988      &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
 989      &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
 990      &1000035,4*1000002,1000001,2000001,1000001,2000001,1000021,3*-11,
 991      &3*-13,3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,
 992      &1000035,4*1000003,1000004,2000004,1000004,2000004,1000021,3*-12,
 993      &3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,
 994      &15,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
 995      &4*1000004,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13,
 996      &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
 997      &4*1000005,1000006,2000006,1000006,2000006,1000021,3*-12,3*-14,
 998      &3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,
 999      &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
1000      &4*1000006,1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,
1001      &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1002      &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1003      &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1004      &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1005      &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1006      &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016/
1007       DATA (KFDP(I,1),I=3677,8000)/1000016,2000016,2*12,2*14,2*16,
1008      &3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,6,11,13,15,21,2*4,2,4,24,-11,
1009      &-13,-15,3,4,5,6,11,13,15,21,5,6,21,2*24,2*3000211,2*22,2*23,1,2,
1010      &3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*3000211,24,4*-1,4*-3,
1011      &4*-5,4*-7,-11,-13,-15,-17,22,23,22,23,24,3000211,24,3000211,1,2,
1012      &3,4,5,6,7,8,11,12,13,14,15,16,17,18,1,2,3,4,5,6,1,2,3,4,5,6,21,1,
1013      &2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,
1014      &21,3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,
1015      &3,4,5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,0,9*11,9*-11,
1016      &2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,
1017      &6,11,12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,
1018      &-13,-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,4011*0/
1019       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,
1020      &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,
1021      &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,
1022      &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1023      &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1024      &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1025      &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1026      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1027      &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1028      &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1029      &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1030      &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1031      &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1032      &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1033      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1034      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1035      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1036      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1037      &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1038      &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/
1039       DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1040      &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1041      &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1042      &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1043      &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1044      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1045      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1046      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1047      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1048      &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1049      &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1050      &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1051      &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1052      &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1053      &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1054      &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1055      &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1056      &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1057      &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1058      &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1059       DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1060      &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1061      &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1062      &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1063      &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1064      &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1065      &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1066      &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1067      &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1068      &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1069      &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1070      &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1071      &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1072      &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1073      &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1074      &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1075      &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1076      &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1077      &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1078      &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1079       DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1080      &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1081      &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1082      &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1083      &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1084      &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1085      &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1086      &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1087      &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1088      &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1089      &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1090      &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1091      &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1092      &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1093      &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1094      &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1095      &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,
1096      &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,
1097      &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,
1098      &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/
1099       DATA (KFDP(I,2),I=1353,1822)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1100      &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,
1101      &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,
1102      &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,
1103      &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1104      &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1105      &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1106      &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1107      &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1108      &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1109      &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1110      &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1111      &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1112      &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,2*24,
1113      &2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,2*-24,2*-37,3,1,3,5,1,3,5,1,3,
1114      &5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,4*4,2*24,2*37,4,1,3,
1115      &5,1,3,5,1,3,2*5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,
1116      &5,6,1,2,3,4,5,6,1,2,3,4,5,2*6,2*5,4*6,2*24,2*37,6,4,-15,16,1,3,5,
1117      &1,3,5,1,3,5,11,2*12,4*11,2*-24,-37,13,15,11,15,11,13,11,13,15,11,
1118      &13,15,1,3,5,1,3,5,1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15/
1119       DATA (KFDP(I,2),I=1823,2288)/1,3,5,1,3,5,1,3,5,13,2*14,4*13,
1120      &2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,
1121      &5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,
1122      &2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,
1123      &1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,
1124      &1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,
1125      &-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,
1126      &-5,1,-1,3,-3,5,-5,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,-15,
1127      &15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,
1128      &11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,
1129      &-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,
1130      &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1131      &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1132      &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,23,25,35,36,
1133      &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,
1134      &15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,
1135      &-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,
1136      &6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,
1137      &-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,
1138      &15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11/
1139       DATA (KFDP(I,2),I=2289,2743)/11,-11,11,-13,13,-13,13,-13,13,-1,1,
1140      &-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,
1141      &-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,
1142      &-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,
1143      &-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,
1144      &-6,6,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,
1145      &-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,
1146      &2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,
1147      &-13,-15,16,2*-15,16,2*-15,16,-15,6*-11,-15,16,2*-15,16,2*-15,16,
1148      &-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,
1149      &-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,
1150      &-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,
1151      &6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,
1152      &-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,22,
1153      &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1154      &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
1155      &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
1156      &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
1157      &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1158      &-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15/
1159       DATA (KFDP(I,2),I=2744,3191)/15,-11,11,-11,11,-11,11,-15,15,-15,
1160      &15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,
1161      &1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,
1162      &6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,
1163      &3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,
1164      &2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,
1165      &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1166      &13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,
1167      &2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,
1168      &13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,
1169      &-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,
1170      &-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,
1171      &4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1172      &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,
1173      &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1174      &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1175      &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,
1176      &-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,
1177      &-5,5,-6,6,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1178      &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11/
1179       DATA (KFDP(I,2),I=3192,3692)/-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,
1180      &2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,
1181      &14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,
1182      &2*-11,12,-11,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,2*-11,
1183      &12,-11,-13,14,2*-13,14,2*-13,14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,
1184      &-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,
1185      &-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,
1186      &-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,
1187      &2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,
1188      &-5,6,-5,-6,-5,6,1,2*2,4*1,23,25,35,36,2*-24,2*-37,2*1,3,5,1,3,5,
1189      &1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,23,25,35,36,
1190      &2*24,2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,23,25,35,36,2*-24,2*-37,
1191      &3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,
1192      &4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,3,5,1,3,2*5,2*6,4*5,23,25,35,
1193      &36,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,
1194      &4,5,2*6,2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,11,
1195      &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1196      &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,
1197      &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,
1198      &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3/
1199       DATA (KFDP(I,2),I=3693,8000)/5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,
1200      &-15,21,-1,-3,2*-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,
1201      &-24,-3000211,-24,-3000211,3000111,3000221,3000111,3000221,-1,-2,
1202      &-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,23,3000111,23,
1203      &3000111,22,3000221,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1204      &2*3000111,2*3000221,-3000211,2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,
1205      &-8,-11,-12,-13,-14,-15,-16,-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,
1206      &-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,
1207      &-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1208      &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1209      &21,22,23,-24,0,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1210      &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1211      &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1212      &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1213      &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,4011*0/
1214       DATA (KFDP(I,3),I=   1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1215      &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1216      &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1217      &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1218      &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1219      &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1220      &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1221      &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1222      &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1223      &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1224      &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1225      &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1226      &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1227      &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1228      &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1229      &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1230      &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1231      &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1232      &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1233      &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1234       DATA (KFDP(I,3),I=1022,2197)/511,513,511,513,1,2,13*0,2*21,11*0,
1235      &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1236      &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1237      &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,
1238      &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,
1239      &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,
1240      &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,
1241      &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,
1242      &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,
1243      &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1244      &-211,111,13*0,2*21,-211,111,175*0,2*5,207*0,-1,-3,-5,-2,-4,-6,-1,
1245      &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1246      &6,-2,2,-4,4,-6,6,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1247      &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1248      &-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1249      &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1250      &3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1251      &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1252      &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,-15,-12,-14,-16,
1253      &-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14/
1254       DATA (KFDP(I,3),I=2198,2789)/14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,
1255      &-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1256      &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1257      &-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1258      &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1259      &1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1260      &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1261      &3,-3,5,-5,5,-5,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
1262      &12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,
1263      &-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,14,-13,13,16,-15,15,
1264      &12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1265      &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,
1266      &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,
1267      &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,
1268      &2*2,1,-1,2*4,3,-3,2*6,5,-5,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,
1269      &-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,
1270      &14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,
1271      &-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1272      &-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1273      &-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5/
1274       DATA (KFDP(I,3),I=2790,3335)/-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1275      &-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,
1276      &-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,
1277      &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,
1278      &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1279      &-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
1280      &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
1281      &-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1282      &13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1283      &13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1284      &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1285      &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1286      &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1287      &1,-1,3,-3,3,-3,5,-5,5,-5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1288      &-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1289      &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1290      &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1291      &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1292      &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,
1293      &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/
1294       DATA (KFDP(I,3),I=3336,8000)/2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1295      &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,
1296      &2*4,3,-3,2*6,5,-5,324*0,-5,170*0,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1297      &-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1298      &-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1299      &-4,-6,-2,-4,-6,2*9900012,2*9900014,4052*0/
1300       DATA (KFDP(I,4),I=   1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1301      &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1302      &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1303      &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1304      &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1305      &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1306      &-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,
1307      &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1308      &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,
1309      &162*81,31*0,-211,111,6516*0/
1310       DATA (KFDP(I,5),I=   1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1311      &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1312      &3*111,-211,111,7193*0/
1313
1314 C...PYDAT4, with particle names (character strings).
1315       DATA (CHAF(I,1),I=   1, 202)/'d','u','s','c','b','t','b''','t''',
1316      &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1317      &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1318      &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1319      &'specflav','rndmflav','phasespa','c-hadron','b-hadron',4*' ',
1320      &'system','cluster','string','indep.','CMshower','SPHEaxis',
1321      &'THRUaxis','CLUSjet','CELLjet','table',' ','reggeon','pi0',
1322      &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1323      &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1324      &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1325      &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1326      &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1327      &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1328      &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1329      &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1330      &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1331      &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1332      &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1333      &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1334      &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1335       DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1336      &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1337      &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1338      &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1339      &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1340      &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1341      &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1342      &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1343      &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1344      &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1345      &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1346      &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1347      &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1348      &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1349      &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1350      &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1351      &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1352      &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1353      &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1354      &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1355       DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1356      &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1357      &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1358      &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1359      &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1360      &'n_diffr0','p_diffr+',139*' '/
1361       DATA (CHAF(I,2),I=   1, 205)/'dbar','ubar','sbar','cbar','bbar',
1362      &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1363      &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1364      &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1365      &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1366      &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1367      &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1368      &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1369      &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1370      &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1371      &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1372      &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1373      &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1374      &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1375      &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1376      &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1377      &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1378      &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1379      &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1380      &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1381       DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1382      &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1383      &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1384      &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1385      &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1386      &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1387      &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1388      &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1389      &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1390      &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1391      &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1392      &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1393      &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1394      &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1395      &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1396      &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1397      &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1398      &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1399      &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1400      &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1401       DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1402      &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1403      &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1404      &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1405
1406 C...PYDATR, with initial values for the random number generator.
1407       DATA MRPY/19780503,0,0,97,33,0/
1408
1409 C...Default values for allowed processes and kinematics constraints.
1410       DATA MSEL/1/
1411       DATA MSUB/500*0/
1412       DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1413      &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,
1414      &6*1,4*0,4*1,16*0/
1415       DATA CKIN/
1416      &  2.0D0, -1.0D0,  0.0D0, -1.0D0,  1.0D0,
1417      &  1.0D0,  -10D0,   10D0,  -40D0,   40D0,
1418      1  -40D0,   40D0,  -40D0,   40D0,  -40D0,
1419      1   40D0, -1.0D0,  1.0D0, -1.0D0,  1.0D0,
1420      2  0.0D0,  1.0D0,  0.0D0,  1.0D0, -1.0D0,
1421      2  1.0D0, -1.0D0,  1.0D0,    0D0,    0D0,
1422      3  2.0D0, -1.0D0,    0D0,    0D0,  0.0D0,
1423      3 -1.0D0,  0.0D0, -1.0D0,  4.0D0, -1.0D0,
1424      4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1425      4 -1.0D0, 12.0D0, -1.0D0,    0D0,    0D0,
1426      5  0.0D0, -1.0D0,  0.0D0, -1.0D0,  0.0D0,
1427      5 -1.0D0,    0D0,    0D0,    0D0,    0D0,
1428      6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0,    0D0,
1429      6   -1D0,    0D0,   -1D0,    0D0,   -1D0,
1430      7    0D0,   -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1431      7 0.99D0,    2D0,   -1D0,    0D0,    0D0,
1432      8  120*0D0/
1433
1434 C...Default values for main switches and parameters. Reset information.
1435       DATA (MSTP(I),I=1,100)/
1436      &  3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
1437      1  1,    0,    1,   30,    0,    1,    4,    3,    4,    3,
1438      2  1,    0,    1,    0,    0,    0,    0,    0,    0,    1,
1439      3  1,    8,    0,    1,    0,    2,    1,    5,    2,    0,
1440      4  2,    1,    3,    7,    3,    1,    1,    0,    1,    0,
1441      5  7,    1,    3,    1,    5,    1,    1,    5,    1,    7,
1442      6  2,    3,    2,    2,    1,    5,    2,    1,    0,    0,
1443      7  1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1444      8  1,    1,  100,    0,    0,    2,    0,    0,    0,    0,
1445      9  1,    3,    1,    3,    0,    0,    0,    0,    0,    0/
1446       DATA (MSTP(I),I=101,200)/
1447      &  3,    1,    0,    0,    0,    0,    0,    0,    0,    0,
1448      1  1,    1,    1,    0,    0,    0,    0,    0,    0,    0,
1449      2  0,    1,    2,    1,    1,  100,    0,    0,   10,    0,
1450      3  0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
1451      4  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1452      5  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1453      6  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1454      7  0,    2,    0,    0,    0,    0,    0,    0,    0,    0,
1455      8  6,  203, 2001,   11,   13,    0,    0,    0,    0,    0,
1456      9  0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1457       DATA (PARP(I),I=1,100)/
1458      &  0.25D0,  10D0, 8*0D0,
1459      1  0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1460      2  10*0D0,
1461      3  1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1462      4  0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1463      5  10*0D0,
1464      6  0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1465      7  4.0D0, 0.25D0, 8*0D0,
1466      8  1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1467      8  0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1468      9  1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1469       DATA (PARP(I),I=101,200)/
1470      &  0.5D0, 0.28D0,  1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1471      1  2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1472      2  1.0D0,  0.4D0, 8*0D0,
1473      3  0.01D0, 5*0D0, 200D0, 200D0, 0.333D0, 0.05D0,
1474      4  0.33333D0, 82D0, 1.33333D0, 4D0, 1D0,
1475      4  1D0,  .0182D0, 1D0, 0D0, 1.33333D0,
1476      5  0D0, 0D0, 0D0, 0D0, 0.3651480D0, 200D0, 0D0, 0D0, 0D0, 0D0,
1477      6  2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1478      7  0D0,   0D0,   0D0,  1.0D0, 6*0D0,
1479      8  0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1480      8  0.3D0, 0.64D0,
1481      9  0.64D0, 5.0D0, 8*0D0/
1482       DATA MSTI/200*0/
1483       DATA PARI/200*0D0/
1484       DATA MINT/400*0/
1485       DATA VINT/400*0D0/
1486
1487 C...Constants for the generation of the various processes.
1488       DATA (ISET(I),I=1,100)/
1489      &  1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,    2,
1490      1  2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1491      2 -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1492      3  2,    2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,
1493      4 -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
1494      5 -1,   -1,    2,    2,   -1,   -1,   -1,    2,   -1,   -1,
1495      6 -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,    2,    2,
1496      7  4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,    2,
1497      8  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1498      9  0,    0,    0,    0,    0,    9,   -2,   -2,    8,   -2/
1499       DATA (ISET(I),I=101,200)/
1500      & -1,    1,    1,    1,    1,    2,    2,    2,   -2,    2,
1501      1  2,    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,
1502      2  5,    5,    5,    5,   -2,   -2,   -2,   -2,   -2,   -2,
1503      3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1504      4  1,    1,    1,    1,    1,    1,    1,    1,    1,   -2,
1505      5  1,    1,    1,   -2,   -2,    1,    1,    1,   -2,   -2,
1506      6  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1507      7  2,    2,    5,    5,   -2,    2,    2,    5,    5,   -2,
1508      8  5,    5,    2,    2,    2,    5,    5,    2,    2,    2,
1509      9  1,    1,    1,    2,    2,   -2,   -2,   -2,   -2,   -2/
1510       DATA (ISET(I),I=201,300)/
1511      &  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1512      1  2,    2,    2,    2,   -2,    2,    2,    2,    2,    2,
1513      2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1514      3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1515      4  2,    2,    2,    2,   -1,    2,    2,    2,    2,    2,
1516      5  2,    2,    2,    2,   -1,    2,   -1,    2,    2,   -2,
1517      6  2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,   -1,
1518      7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1519      8  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1520      9  2,    2,    2,    2,    2,    2,    2,    2,    2,    2/
1521       DATA (ISET(I),I=301,500)/
1522      &  2,   39*-2,
1523      4  1,    1,    2,    2,    2,    2,    2,    2,    2,    2,
1524      5  5,    5,    1,    1,   -1,   -1,   -1,   -1,   -1,   -1,
1525      6  2,    2,    2,    2,    2,    2,    2,    2,   -1,    2,
1526      7  2,    2,    2,    2,    2,    2,    2,   -1,   -1,   -1,
1527      8  10*-2,
1528      9  1,    1,    2,    2,    2, 5*-2,
1529      &  100*-2/
1530       DATA ((KFPR(I,J),J=1,2),I=1,50)/
1531      &  23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
1532      &  24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
1533      1   0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
1534      1  21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
1535      2  22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
1536      2  24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
1537      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1538      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1539      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1540      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
1541       DATA ((KFPR(I,J),J=1,2),I=51,100)/
1542      5   0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
1543      5   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1544      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1545      6   0,    0,    0,    0,   21,   21,   24,   24,   23,   24,
1546      7  23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
1547      7  23,   23,   24,   24,   24,   25,   25,   25,    0,  211,
1548      8   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1549      8 443,   21,10441,   21,20443,   21,  445,   21,    0,    0,
1550      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1551      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1552       DATA ((KFPR(I,J),J=1,2),I=101,150)/
1553      &  23,    0,   25,    0,   25,    0,10441,    0,  445,    0,
1554      & 443,   22,  443,   21,  443,   22,    0,    0,   22,   25,
1555      1  21,   25,    0,   25,   21,   25,   22,   22,   21,   22,
1556      1  22,   23,   23,   23,   24,   24,    0,    0,    0,    0,
1557      2  25,    6,   25,    6,   25,    0,   25,    0,    0,    0,
1558      2   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1559      3   0,   21,    0,   21,    0,   22,    0,   22,    0,    0,
1560      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1561      4  32,    0,   34,    0,   37,    0,   41,    0,   42,    0,
1562      4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0,   0,    0/
1563       DATA ((KFPR(I,J),J=1,2),I=151,200)/
1564      5  35,    0,   35,    0,   35,    0,    0,    0,    0,    0,
1565      5  36,    0,   36,    0,   36,    0,    0,    0,    0,    0,
1566      6   6,   37,   42,    0,   42,   42,   42,   42,   11,    0,
1567      6  11,    0, 0, 4000001, 0, 4000002, 0, 4000011,    0,    0,
1568      7  23,   35,   24,   35,   35,    0,   35,    0,    0,    0,
1569      7  23,   36,   24,   36,   36,    0,   36,    0,    0,    0,
1570      8  35,    6,   35,    6,   21,   35,    0,   35,   21,   35,
1571      8  36,    6,   36,    6,   21,   36,    0,   36,   21,   36,
1572      9  3000113, 0, 3000213, 0, 3000223, 0, 11,    0,   11,    0,
1573      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1574       DATA ((KFPR(I,J),J=1,2),I=201,250)/
1575      &  1000011,   1000011,   2000011,   2000011,   1000011,
1576      &  2000011,   1000013,   1000013,   2000013,   2000013,
1577      &  1000013,   2000013,   1000015,   1000015,   2000015,
1578      &  2000015,   1000015,   2000015,   1000011,   1000012,
1579      1  1000015,   1000016,   2000015,   1000016,   1000012,
1580      1  1000012,   1000016,   1000016,         0,         0,
1581      1  1000022,   1000022,   1000023,   1000023,   1000025,
1582      1  1000025,   1000035,   1000035,   1000022,   1000023,
1583      2  1000022,   1000025,   1000022,   1000035,   1000023,
1584      2  1000025,   1000023,   1000035,   1000025,   1000035,
1585      2  1000024,   1000024,   1000037,   1000037,   1000024,
1586      2  1000037,   1000022,   1000024,   1000023,   1000024,
1587      3  1000025,   1000024,   1000035,   1000024,   1000022,
1588      3  1000037,   1000023,   1000037,   1000025,   1000037,
1589      3  1000035,   1000037,   1000021,   1000022,   1000021,
1590      3  1000023,   1000021,   1000025,   1000021,   1000035,
1591      4  1000021,   1000024,   1000021,   1000037,   1000021,
1592      4  1000021,   1000021,   1000021,         0,         0,
1593      4  1000002,   1000022,   2000002,   1000022,   1000002,
1594      4  1000023,   2000002,   1000023,   1000002,   1000025/
1595       DATA ((KFPR(I,J),J=1,2),I=251,300)/
1596      5  2000002,   1000025,   1000002,   1000035,   2000002,
1597      5  1000035,   1000001,   1000024,   2000005,   1000024,
1598      5  1000001,   1000037,   2000005,   1000037,   1000002,
1599      5  1000021,   2000002,   1000021,         0,         0,
1600      6  1000006,   1000006,   2000006,   2000006,   1000006,
1601      6  2000006,   1000006,   1000006,   2000006,   2000006,
1602      6        0,         0,         0,         0,         0,
1603      6        0,         0,         0,         0,         0,
1604      7  1000002,   1000002,   2000002,   2000002,   1000002,
1605      7  2000002,   1000002,   1000002,   2000002,   2000002,
1606      7  1000002,   2000002,   1000002,   1000002,   2000002,
1607      7  2000002,   1000002,   1000002,   2000002,   2000002,
1608      8  1000005,   1000002,   2000005,   2000002,   1000005,
1609      8  2000002,   1000005,   1000002,   2000005,   2000002,
1610      8  1000005,   2000002,   1000005,   1000005,   2000005,
1611      8  2000005,   1000005,   1000005,   2000005,   2000005,
1612      9  1000005,   1000005,   2000005,   2000005,   1000005,
1613      9  2000005,   1000005,   1000021,   2000005,   1000021,
1614      9  1000005,   2000005,        37,        25,        37,
1615      9       35,        36,        25,        36,        35/
1616       DATA ((KFPR(I,J),J=1,2),I=301,500)/
1617      &       37,        37,      78*0,
1618      4  9900041,         0,   9900042,         0,   9900041,
1619      4       11,   9900042,        11,   9900041,        13,
1620      4  9900042,        13,   9900041,        15,   9900042,
1621      4       15,   9900041,   9900041,   9900042,   9900042,
1622      5  9900041,         0,   9900042,         0,   9900023,
1623      5        0,   9900024,         0,         0,         0,
1624      5        0,         0,         0,         0,         0,
1625      5        0,         0,         0,         0,         0,
1626      6       24,        24,        24,   3000211,   3000211,
1627      6  3000211,        22,   3000111,        22,   3000221,
1628      6       23,   3000111,        23,   3000221,        24,
1629      6  3000211,         0,         0,        24,        23,
1630      7       24,   3000111,   3000211,        23,   3000211,
1631      7  3000111,        22,   3000211,        23,   3000211,
1632      7       24,   3000111,        24,   3000221,         0,
1633      7        0,         0,         0,         0,         0,
1634      8     20*0,
1635      9  5000039,         0,   5000039,         0,        21,
1636      9  5000039,         0,   5000039,        21,   5000039,
1637      9     10*0,
1638      &    200*0/
1639       DATA COEF/10000*0D0/
1640       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1641      &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,
1642      &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,
1643      &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,
1644      &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,
1645      &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,
1646      &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,
1647      &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,
1648      &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,
1649      &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,
1650      &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/
1651
1652 C...Treatment of resonances.
1653       DATA (MWID(I)  ,I=   1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1654      &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1655
1656 C...Character constants: name of processes.
1657       DATA PROC(0)/                    'All included subprocesses   '/
1658       DATA (PROC(I),I=1,20)/
1659      &'f + fbar -> gamma*/Z0       ',  'f + fbar'' -> W+/-           ',
1660      &'f + fbar -> h0              ',  'gamma + W+/- -> W+/-        ',
1661      &'Z0 + Z0 -> h0               ',  'Z0 + W+/- -> W+/-           ',
1662      &'                            ',  'W+ + W- -> h0               ',
1663      &'                            ',  'f + f'' -> f + f'' (QFD)      ',
1664      1'f + f'' -> f + f'' (QCD)      ','f + fbar -> f'' + fbar''      ',
1665      1'f + fbar -> g + g           ',  'f + fbar -> g + gamma       ',
1666      1'f + fbar -> g + Z0          ',  'f + fbar'' -> g + W+/-       ',
1667      1'f + fbar -> g + h0          ',  'f + fbar -> gamma + gamma   ',
1668      1'f + fbar -> gamma + Z0      ',  'f + fbar'' -> gamma + W+/-   '/
1669       DATA (PROC(I),I=21,40)/
1670      2'f + fbar -> gamma + h0      ',  'f + fbar -> Z0 + Z0         ',
1671      2'f + fbar'' -> Z0 + W+/-      ', 'f + fbar -> Z0 + h0         ',
1672      2'f + fbar -> W+ + W-         ',  'f + fbar'' -> W+/- + h0      ',
1673      2'f + fbar -> h0 + h0         ',  'f + g -> f + g              ',
1674      2'f + g -> f + gamma          ',  'f + g -> f + Z0             ',
1675      3'f + g -> f'' + W+/-          ', 'f + g -> f + h0             ',
1676      3'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',
1677      3'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',
1678      3'f + gamma -> f + h0         ',  'f + Z0 -> f + g             ',
1679      3'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/
1680       DATA (PROC(I),I=41,60)/
1681      4'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + h0            ',
1682      4'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',
1683      4'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',
1684      4'f + W+/- -> f'' + h0         ', 'f + h0 -> f + g             ',
1685      4'f + h0 -> f + gamma         ',  'f + h0 -> f + Z0            ',
1686      5'f + h0 -> f'' + W+/-         ', 'f + h0 -> f + h0            ',
1687      5'g + g -> f + fbar           ',  'g + gamma -> f + fbar       ',
1688      5'g + Z0 -> f + fbar          ',  'g + W+/- -> f + fbar''       ',
1689      5'g + h0 -> f + fbar          ',  'gamma + gamma -> f + fbar   ',
1690      5'gamma + Z0 -> f + fbar      ',  'gamma + W+/- -> f + fbar''   '/
1691       DATA (PROC(I),I=61,80)/
1692      6'gamma + h0 -> f + fbar      ',  'Z0 + Z0 -> f + fbar         ',
1693      6'Z0 + W+/- -> f + fbar''      ', 'Z0 + h0 -> f + fbar         ',
1694      6'W+ + W- -> f + fbar         ',  'W+/- + h0 -> f + fbar''      ',
1695      6'h0 + h0 -> f + fbar         ',  'g + g -> g + g              ',
1696      6'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> Z0 + W+/-   ',
1697      7'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',
1698      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + h0          ',
1699      7'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',
1700      7'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + h0 -> W+/- + h0      ',
1701      7'h0 + h0 -> h0 + h0          ',  'q + gamma -> q'' + pi+/-     '/
1702       DATA (PROC(I),I=81,100)/
1703      8'q + qbar -> Q + Qbar, mass  ',  'g + g -> Q + Qbar, massive  ',
1704      8'f + q -> f'' + Q, massive    ', 'g + gamma -> Q + Qbar, mass ',
1705      8'gamma + gamma -> F + Fbar, m',  'g + g -> J/Psi + g          ',
1706      8'g + g -> chi_0c + g         ',  'g + g -> chi_1c + g         ',
1707      8'g + g -> chi_2c + g         ',  '                            ',
1708      9'Elastic scattering          ',  'Single diffractive (XB)     ',
1709      9'Single diffractive (AX)     ',  'Double  diffractive         ',
1710      9'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',
1711      9'                            ',  '                            ',
1712      9'q + gamma* -> q             ',  '                            '/
1713       DATA (PROC(I),I=101,120)/
1714      &'g + g -> gamma*/Z0          ',  'g + g -> h0                 ',
1715      &'gamma + gamma -> h0         ',  'g + g -> chi_0c             ',
1716      &'g + g -> chi_2c             ',  'g + g -> J/Psi + gamma      ',
1717      &'gamma + g -> J/Psi + g      ',  'gamma+gamma -> J/Psi + gamma',
1718      &'                            ',  'f + fbar -> gamma + h0      ',
1719      1'q + qbar -> g + h0          ',  'q + g -> q + h0             ',
1720      1'g + g -> g + h0             ',  'g + g -> gamma + gamma      ',
1721      1'g + g -> g + gamma          ',  'g + g -> gamma + Z0         ',
1722      1'g + g -> Z0 + Z0            ',  'g + g -> W+ + W-            ',
1723      1'                            ',  '                            '/
1724       DATA (PROC(I),I=121,140)/
1725      2'g + g -> Q + Qbar + h0      ',  'q + qbar -> Q + Qbar + h0   ',
1726      2'f + f'' -> f + f'' + h0       ',
1727      2'f + f'' -> f" + f"'' + h0     ',
1728      2'                            ',  '                            ',
1729      2'                            ',  '                            ',
1730      2'                            ',  '                            ',
1731      3'f + gamma*_T -> f + g       ',  'f + gamma*_L -> f + g       ',
1732      3'f + gamma*_T -> f + gamma   ',  'f + gamma*_L -> f + gamma   ',
1733      3'g + gamma*_T -> f + fbar    ',  'g + gamma*_L -> f + fbar    ',
1734      3'gamma*_T+gamma*_T -> f+fbar ',  'gamma*_T+gamma*_L -> f+fbar ',
1735      3'gamma*_L+gamma*_T -> f+fbar ',  'gamma*_L+gamma*_L -> f+fbar '/
1736       DATA (PROC(I),I=141,160)/
1737      4'f + fbar -> gamma*/Z0/Z''0   ', 'f + fbar'' -> W''+/-          ',
1738      4'f + fbar'' -> H+/-           ', 'f + fbar'' -> R              ',
1739      4'q + l -> LQ                 ',  'e + gamma -> e*             ',
1740      4'd + g -> d*                 ',  'u + g -> u*                 ',
1741      4'g + g -> eta_tc             ',  '                            ',
1742      5'f + fbar -> H0              ',  'g + g -> H0                 ',
1743      5'gamma + gamma -> H0         ',  '                            ',
1744      5'                            ',  'f + fbar -> A0              ',
1745      5'g + g -> A0                 ',  'gamma + gamma -> A0         ',
1746      5'                            ',  '                            '/
1747       DATA (PROC(I),I=161,180)/
1748      6'f + g -> f'' + H+/-          ', 'q + g -> LQ + lbar          ',
1749      6'g + g -> LQ + LQbar         ',  'q + qbar -> LQ + LQbar      ',
1750      6'f + fbar -> f'' + fbar'' (g/Z)',
1751      6'f +fbar'' -> f" + fbar"'' (W) ',
1752      6'q + q'' -> q" + d*           ',  'q + q'' -> q" + u*           ',
1753      6'q + qbar -> e + e*          ',  '                            ',
1754      7'f + fbar -> Z0 + H0         ', 'f + fbar'' -> W+/- + H0      ',
1755      7'f + f'' -> f + f'' + H0       ',
1756      7'f + f'' -> f" + f"'' + H0     ',
1757      7'                            ',  'f + fbar -> Z0 + A0         ',
1758      7'f + fbar'' -> W+/- + A0      ',
1759      7'f + f'' -> f + f'' + A0       ',
1760      7'f + f'' -> f" + f"'' + A0     ',
1761      7'                            '/
1762       DATA (PROC(I),I=181,200)/
1763      8'g + g -> Q + Qbar + H0      ',  'q + qbar -> Q + Qbar + H0   ',
1764      8'q + qbar -> g + H0          ',  'q + g -> q + H0             ',
1765      8'g + g -> g + H0             ',  'g + g -> Q + Qbar + A0      ',
1766      8'q + qbar -> Q + Qbar + A0   ',  'q + qbar -> g + A0          ',
1767      8'q + g -> q + A0             ',  'g + g -> g + A0             ',
1768      9'f + fbar -> rho_tc0         ',  'f + f'' -> rho_tc+/-         ',
1769      9'f + fbar -> omega_tc0      ',  'f+fbar -> f''+fbar'' (ETC)  ',
1770      9'f+fbar'' -> f"+fbar"'' (ETC)','                          ',
1771      9'                            ',  '                            ',
1772      9'                            ',  '                            '/
1773       DATA (PROC(I),I=201,220)/
1774      &'f + fbar -> ~e_L + ~e_Lbar  ',  'f + fbar -> ~e_R + ~e_Rbar  ',
1775      &'f + fbar -> ~e_R + ~e_Lbar  ',  'f + fbar -> ~mu_L + ~mu_Lbar',
1776      &'f + fbar -> ~mu_R + ~mu_Rbar',  'f + fbar -> ~mu_L + ~mu_Rbar',
1777      &'f+fbar -> ~tau_1 + ~tau_1bar',  'f+fbar -> ~tau_2 + ~tau_2bar',
1778      &'f+fbar -> ~tau_1 + ~tau_2bar',  'q + qbar'' -> ~l_L + ~nulbar ',
1779      1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1780      1'f + fbar -> ~nul + ~nulbar  ',  'f+fbar -> ~nutau + ~nutaubar',
1781      1'                            ',  'f + fbar -> ~chi1 + ~chi1   ',
1782      1'f + fbar -> ~chi2 + ~chi2   ',  'f + fbar -> ~chi3 + ~chi3   ',
1783      1'f + fbar -> ~chi4 + ~chi4   ',  'f + fbar -> ~chi1 + ~chi2   '/
1784       DATA (PROC(I),I=221,240)/
1785      2'f + fbar -> ~chi1 + ~chi3   ',  'f + fbar -> ~chi1 + ~chi4   ',
1786      2'f + fbar -> ~chi2 + ~chi3   ',  'f + fbar -> ~chi2 + ~chi4   ',
1787      2'f + fbar -> ~chi3 + ~chi4   ',  'f+fbar -> ~chi+-1 + ~chi-+1 ',
1788      2'f+fbar -> ~chi+-2 + ~chi-+2 ',  'f+fbar -> ~chi+-1 + ~chi-+2 ',
1789      2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1790      3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1791      3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1792      3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1793      3'q + qbar -> ~chi1 + ~g      ',  'q + qbar -> ~chi2 + ~g      ',
1794      3'q + qbar -> ~chi3 + ~g      ',  'q + qbar -> ~chi4 + ~g      '/
1795       DATA (PROC(I),I=241,260)/
1796      4'q + qbar'' -> ~chi+-1 + ~g   ', 'q + qbar'' -> ~chi+-2 + ~g  ',
1797      4'q + qbar -> ~g + ~g         ',  'g + g -> ~g + ~g            ',
1798      4'                            ',  'qj + g -> ~qj_L + ~chi1     ',
1799      4'qj + g -> ~qj_R + ~chi1     ',  'qj + g -> ~qj_L + ~chi2     ',
1800      4'qj + g -> ~qj_R + ~chi2     ',  'qj + g -> ~qj_L + ~chi3     ',
1801      5'qj + g -> ~qj_R + ~chi3     ',  'qj + g -> ~qj_L + ~chi4     ',
1802      5'qj + g -> ~qj_R + ~chi4     ',  'qj + g -> ~qk_L + ~chi+-1   ',
1803      5'qj + g -> ~qk_R + ~chi+-1   ',  'qj + g -> ~qk_L + ~chi+-2   ',
1804      5'qj + g -> ~qk_R + ~chi+-2   ',  'qj + g -> ~qj_L + ~g        ',
1805      5'qj + g -> ~qj_R + ~g        ',  '                            '/
1806       DATA (PROC(I),I=261,300)/
1807      6'f + fbar -> ~t_1 + ~t_1bar  ',  'f + fbar -> ~t_2 + ~t_2bar  ',
1808      6'f + fbar -> ~t_1 + ~t_2bar  ',  'g + g -> ~t_1 + ~t_1bar     ',
1809      6'g + g -> ~t_2 + ~t_2bar     ',  '                            ',
1810      6'                            ',  '                            ',
1811      6'                            ',  '                            ',
1812      7'qi + qj -> ~qi_L + ~qj_L    ',  'qi + qj -> ~qi_R + ~qj_R    ',
1813      7'qi + qj -> ~qi_L + ~qj_R    ',  'qi+qjbar -> ~qi_L + ~qj_Lbar',
1814      7'qi+qjbar -> ~qi_R + ~qj_Rbar',  'qi+qjbar -> ~qi_L + ~qj_Rbar',
1815      7'f + fbar -> ~qi_L + ~qi_Lbar',  'f + fbar -> ~qi_R + ~qi_Rbar',
1816      7'g + g -> ~qi_L + ~qi_Lbar   ',  'g + g -> ~qi_R + ~qi_Rbar   ',
1817      8'b + qj -> ~b_1 + ~qj_L      ',  'b + qj -> ~b_2 + ~qj_R      ',
1818      8'b + qj -> ~b_1 + ~qj_R      ',  'b + qjbar -> ~b_1 + ~qj_Lbar',
1819      8'b + qjbar -> ~b_2 + ~qj_Rbar',  'b + qjbar -> ~b_1 + ~qj_Rbar',
1820      8'f + fbar -> ~b_1 + ~b_1bar  ',  'f + fbar -> ~b_2 + ~b_2bar  ',
1821      8'g + g -> ~b_1 + ~b_1bar     ',  'g + g -> ~b_2 + ~b_2bar     ',
1822      9'b + b -> ~b_1 + ~b_1        ',  'b + b -> ~b_2 + ~b_2        ',
1823      9'b + b -> ~b_1 + ~b_2        ',  'b + g -> ~b_1 + ~g          ',
1824      9'b + g -> ~b_2 + ~g          ',  'b + bbar -> ~b_1 + ~b_2bar  ',
1825      9'f + fbar'' -> H+/- + h0     ',  'f + fbar -> H+/- + H0       ',
1826      9'f + fbar -> A0 + h0         ',  'f + fbar -> A0 + H0         '/
1827       DATA (PROC(I),I=301,340)/
1828      &'f + fbar -> H+ + H-         ', 39*'                          '/
1829       DATA (PROC(I),I=341,380)/
1830      4'l + l -> H_L++/--           ',  'l + l -> H_R++/--           ',
1831      4'l + gamma -> H_L++/-- e-/+  ',  'l + gamma -> H_R++/-- e-/+  ',
1832      4'l + gamma -> H_L++/-- mu-/+ ',  'l + gamma -> H_R++/-- mu-/+ ',
1833      4'l + gamma -> H_L++/-- tau-/+',  'l + gamma -> H_R++/-- tau-/+',
1834      4'f + fbar -> H_L++ + H_L--   ',  'f + fbar -> H_R++ + H_R--   ',
1835      5'f + f -> f'' + f'' + H_L++/-- ',
1836      5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0            ',
1837      5'f + fbar'' -> W_R+/-         ',5*'                            ',
1838      6'                            ',  'f + fbar -> W_L+ W_L-       ',
1839      6'f + fbar -> W_L+/- pi_T-/+  ',  'f + fbar -> pi_T+ pi_T-     ',
1840      6'f + fbar -> gamma pi_T0     ',  'f + fbar -> gamma pi_T0''    ',
1841      6'f + fbar -> Z0 pi_T0        ',  'f + fbar -> Z0 pi_T0''       ',
1842      6'f + fbar -> W+/- pi_T-/+    ',  '                            ',
1843      7'f + fbar'' -> W_L+/- Z_L0    ', 'f + fbar'' -> W_L+/- pi_T0   ',
1844      7'f + fbar'' -> pi_T+/- Z_L0   ', 'f + fbar'' -> pi_T+/- pi_T0  ',
1845      7'f + fbar'' -> gamma pi_T+/-  ', 'f + fbar'' -> Z0 pi_T+/-     ',
1846      7'f + fbar'' -> W+/- pi_T0     ',
1847      7'f + fbar'' -> W+/- pi_T0''    ',
1848      7'                            ','                              ',
1849      7'                            '/
1850       DATA (PROC(I),I=381,500)/
1851      8 10* '                            ',
1852      9'f + fbar -> G*              ','g + g -> G*                   ',
1853      9'q + qbar -> g + G*          ','q + g -> q + G*               ',
1854      9'g + g -> g + G*             ','                              ',
1855      & 104*'                      '/
1856
1857 C...Cross sections and slope offsets.
1858       DATA SIGT/294*0D0/
1859
1860 C...Supersymmetry switches and parameters.
1861       DATA IMSS/0,
1862      &  0,  0,  0,  1,  0,  0,  0,  1,  0,  0,
1863      1  89*0/
1864       DATA RMSS/0D0,
1865      &  80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1866      1  700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1867      2   1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1868      3  69*0D0/
1869 C...Initial values for R-violating SUSY couplings.
1870 C...Should not be changed here. See PYMSIN.
1871       DATA RVLAM/27*0D0/
1872       DATA RVLAMP/27*0D0/
1873       DATA RVLAMB/27*0D0/
1874
1875 C...Data for histogramming routines.
1876       DATA IHIST/1000,20000,55,1/
1877       DATA INDX/1000*0/
1878
1879       END
1880
1881 C*********************************************************************
1882
1883 C...PYTEST
1884 C...A simple program (disguised as subroutine) to run at installation
1885 C...as a check that the program works as intended.
1886
1887       SUBROUTINE PYTEST(MTEST)
1888
1889 C...Double precision and integer declarations.
1890       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1891       IMPLICIT INTEGER(I-N)
1892       INTEGER PYK,PYCHGE,PYCOMP
1893 C...Commonblocks.
1894       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1895       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1896       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1897       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1898       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1899       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1900       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1901 C...Local arrays.
1902       DIMENSION PSUM(5),PINI(6),PFIN(6)
1903
1904 C...Save defaults for values that are changed.
1905       MSTJ1=MSTJ(1)
1906       MSTJ3=MSTJ(3)
1907       MSTJ11=MSTJ(11)
1908       MSTJ42=MSTJ(42)
1909       MSTJ43=MSTJ(43)
1910       MSTJ44=MSTJ(44)
1911       PARJ17=PARJ(17)
1912       PARJ22=PARJ(22)
1913       PARJ43=PARJ(43)
1914       PARJ54=PARJ(54)
1915       MST101=MSTJ(101)
1916       MST104=MSTJ(104)
1917       MST105=MSTJ(105)
1918       MST107=MSTJ(107)
1919       MST116=MSTJ(116)
1920
1921 C...First part: loop over simple events to be generated.
1922       IF(MTEST.GE.1) CALL PYTABU(20)
1923       NERR=0
1924       DO 180 IEV=1,500
1925
1926 C...Reset parameter values. Switch on some nonstandard features.
1927         MSTJ(1)=1
1928         MSTJ(3)=0
1929         MSTJ(11)=1
1930         MSTJ(42)=2
1931         MSTJ(43)=4
1932         MSTJ(44)=2
1933         PARJ(17)=0.1D0
1934         PARJ(22)=1.5D0
1935         PARJ(43)=1D0
1936         PARJ(54)=-0.05D0
1937         MSTJ(101)=5
1938         MSTJ(104)=5
1939         MSTJ(105)=0
1940         MSTJ(107)=1
1941         IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1942
1943 C...Ten events each for some single jets configurations.
1944         IF(IEV.LE.50) THEN
1945           ITY=(IEV+9)/10
1946           MSTJ(3)=-1
1947           IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1948           IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1949           IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1950           IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1951           IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1952           IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1953
1954 C...Ten events each for some simple jet systems; string fragmentation.
1955         ELSEIF(IEV.LE.130) THEN
1956           ITY=(IEV-41)/10
1957           IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1958           IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1959           IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1960           IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1961           IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1962           IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1963           IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1964           IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1965      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1966
1967 C...Seventy events with independent fragmentation and momentum cons.
1968         ELSEIF(IEV.LE.200) THEN
1969           ITY=1+(IEV-131)/16
1970           MSTJ(2)=1+MOD(IEV-131,4)
1971           MSTJ(3)=1+MOD((IEV-131)/4,4)
1972           IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1973           IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1974           IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1975      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1976           IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1977      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1978
1979 C...A hundred events with random jets (check invariant mass).
1980         ELSEIF(IEV.LE.300) THEN
1981   100     DO 110 J=1,5
1982             PSUM(J)=0D0
1983   110     CONTINUE
1984           NJET=2D0+6D0*PYR(0)
1985           DO 130 I=1,NJET
1986             KFL=21
1987             IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1988             IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1989             EJET=5D0+20D0*PYR(0)
1990             THETA=ACOS(2D0*PYR(0)-1D0)
1991             PHI=6.2832D0*PYR(0)
1992             IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1993             IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1994             IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1995             IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1996             DO 120 J=1,4
1997               PSUM(J)=PSUM(J)+P(I,J)
1998   120       CONTINUE
1999   130     CONTINUE
2000           IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2001      &    (PSUM(5)+PARJ(32))**2) GOTO 100
2002
2003 C...Fifty e+e- continuum events with matrix elements.
2004         ELSEIF(IEV.LE.350) THEN
2005           MSTJ(101)=2
2006           CALL PYEEVT(0,40D0)
2007
2008 C...Fifty e+e- continuum event with varying shower options.
2009         ELSEIF(IEV.LE.400) THEN
2010           MSTJ(42)=1+MOD(IEV,2)
2011           MSTJ(43)=1+MOD(IEV/2,4)
2012           MSTJ(44)=MOD(IEV/8,3)
2013           CALL PYEEVT(0,90D0)
2014
2015 C...Fifty e+e- continuum events with coherent shower.
2016         ELSEIF(IEV.LE.450) THEN
2017           CALL PYEEVT(0,500D0)
2018
2019 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2020         ELSE
2021           CALL PYONIA(5,9.46D0)
2022         ENDIF
2023
2024 C...Generate event. Find total momentum, energy and charge.
2025         DO 140 J=1,4
2026           PINI(J)=PYP(0,J)
2027   140   CONTINUE
2028         PINI(6)=PYP(0,6)
2029         CALL PYEXEC
2030         DO 150 J=1,4
2031           PFIN(J)=PYP(0,J)
2032   150   CONTINUE
2033         PFIN(6)=PYP(0,6)
2034
2035 C...Check conservation of energy, momentum and charge;
2036 C...usually exact, but only approximate for single jets.
2037         MERR=0
2038         IF(IEV.LE.50) THEN
2039           IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2040      &    MERR=MERR+1
2041           EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2042           IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2043           IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2044         ELSE
2045           DO 160 J=1,4
2046             IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2047   160     CONTINUE
2048           IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2049         ENDIF
2050         IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2051      &  (PFIN(J),J=1,4),PFIN(6)
2052
2053 C...Check that all KF codes are known ones, and that partons/particles
2054 C...satisfy energy-momentum-mass relation. Store particle statistics.
2055         DO 170 I=1,N
2056           IF(K(I,1).GT.20) GOTO 170
2057           IF(PYCOMP(K(I,2)).EQ.0) THEN
2058             WRITE(MSTU(11),5100) I
2059             MERR=MERR+1
2060           ENDIF
2061           PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2062           IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2063      &    THEN
2064             WRITE(MSTU(11),5200) I
2065             MERR=MERR+1
2066           ENDIF
2067   170   CONTINUE
2068         IF(MTEST.GE.1) CALL PYTABU(21)
2069
2070 C...List all erroneous events and some normal ones.
2071         IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2072           IF(MERR.GE.1) WRITE(MSTU(11),6400)
2073           CALL PYLIST(2)
2074         ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2075           CALL PYLIST(1)
2076         ENDIF
2077
2078 C...Stop execution if too many errors.
2079         IF(MERR.NE.0) NERR=NERR+1
2080         IF(NERR.GE.10) THEN
2081           WRITE(MSTU(11),6300)
2082           CALL PYLIST(1)
2083           STOP
2084         ENDIF
2085   180 CONTINUE
2086
2087 C...Summarize result of run.
2088       IF(MTEST.GE.1) CALL PYTABU(22)
2089
2090 C...Reset commonblock variables changed during run.
2091       MSTJ(1)=MSTJ1
2092       MSTJ(3)=MSTJ3
2093       MSTJ(11)=MSTJ11
2094       MSTJ(42)=MSTJ42
2095       MSTJ(43)=MSTJ43
2096       MSTJ(44)=MSTJ44
2097       PARJ(17)=PARJ17
2098       PARJ(22)=PARJ22
2099       PARJ(43)=PARJ43
2100       PARJ(54)=PARJ54
2101       MSTJ(101)=MST101
2102       MSTJ(104)=MST104
2103       MSTJ(105)=MST105
2104       MSTJ(107)=MST107
2105       MSTJ(116)=MST116
2106
2107 C...Second part: complete events of various kinds.
2108 C...Common initial values. Loop over initiating conditions.
2109       MSTP(122)=MAX(0,MIN(2,MTEST))
2110       MDCY(PYCOMP(111),1)=0
2111       DO 230 IPROC=1,8
2112
2113 C...Reset process type, kinematics cuts, and the flags used.
2114         MSEL=0
2115         DO 190 ISUB=1,500
2116           MSUB(ISUB)=0
2117   190   CONTINUE
2118         CKIN(1)=2D0
2119         CKIN(3)=0D0
2120         MSTP(2)=1
2121         MSTP(11)=0
2122         MSTP(33)=0
2123         MSTP(81)=1
2124         MSTP(82)=1
2125         MSTP(111)=1
2126         MSTP(131)=0
2127         MSTP(133)=0
2128         PARP(131)=0.01D0
2129
2130 C...Prompt photon production at fixed target.
2131         IF(IPROC.EQ.1) THEN
2132           PZSUM=300D0
2133           PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2134           PQSUM=2D0
2135           MSEL=10
2136           CKIN(3)=5D0
2137           CALL PYINIT('FIXT','pi+','p',PZSUM)
2138
2139 C...QCD processes at ISR energies.
2140         ELSEIF(IPROC.EQ.2) THEN
2141           PESUM=63D0
2142           PZSUM=0D0
2143           PQSUM=2D0
2144           MSEL=1
2145           CKIN(3)=5D0
2146           CALL PYINIT('CMS','p','p',PESUM)
2147
2148 C...W production + multiple interactions at CERN Collider.
2149         ELSEIF(IPROC.EQ.3) THEN
2150           PESUM=630D0
2151           PZSUM=0D0
2152           PQSUM=0D0
2153           MSEL=12
2154           CKIN(1)=20D0
2155           MSTP(82)=4
2156           MSTP(2)=2
2157           MSTP(33)=3
2158           CALL PYINIT('CMS','p','pbar',PESUM)
2159
2160 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2161         ELSEIF(IPROC.EQ.4) THEN
2162           PESUM=1800D0
2163           PZSUM=0D0
2164           PQSUM=0D0
2165           MSUB(22)=1
2166           MSUB(23)=1
2167           MSUB(25)=1
2168           CKIN(1)=200D0
2169           MSTP(111)=0
2170           MSTP(131)=1
2171           MSTP(133)=2
2172           PARP(131)=0.04D0
2173           CALL PYINIT('CMS','p','pbar',PESUM)
2174
2175 C...Higgs production at LHC.
2176         ELSEIF(IPROC.EQ.5) THEN
2177           PESUM=15400D0
2178           PZSUM=0D0
2179           PQSUM=2D0
2180           MSUB(3)=1
2181           MSUB(102)=1
2182           MSUB(123)=1
2183           MSUB(124)=1
2184           PMAS(25,1)=300D0
2185           CKIN(1)=200D0
2186           MSTP(81)=0
2187           MSTP(111)=0
2188           CALL PYINIT('CMS','p','p',PESUM)
2189
2190 C...Z' production at SSC.
2191         ELSEIF(IPROC.EQ.6) THEN
2192           PESUM=40000D0
2193           PZSUM=0D0
2194           PQSUM=2D0
2195           MSEL=21
2196           PMAS(32,1)=600D0
2197           CKIN(1)=400D0
2198           MSTP(81)=0
2199           MSTP(111)=0
2200           CALL PYINIT('CMS','p','p',PESUM)
2201
2202 C...W pair production at 1 TeV e+e- collider.
2203         ELSEIF(IPROC.EQ.7) THEN
2204           PESUM=1000D0
2205           PZSUM=0D0
2206           PQSUM=0D0
2207           MSUB(25)=1
2208           MSUB(69)=1
2209           MSTP(11)=1
2210           CALL PYINIT('CMS','e+','e-',PESUM)
2211
2212 C...Deep inelastic scattering at a LEP+LHC ep collider.
2213         ELSEIF(IPROC.EQ.8) THEN
2214           P(1,1)=0D0
2215           P(1,2)=0D0
2216           P(1,3)=8000D0
2217           P(2,1)=0D0
2218           P(2,2)=0D0
2219           P(2,3)=-80D0
2220           PESUM=8080D0
2221           PZSUM=7920D0
2222           PQSUM=0D0
2223           MSUB(10)=1
2224           CKIN(3)=50D0
2225           MSTP(111)=0
2226           CALL PYINIT('3MOM','p','e-',PESUM)
2227         ENDIF
2228
2229 C...Generate 20 events of each required type.
2230         DO 220 IEV=1,20
2231           CALL PYEVNT
2232           PESUMM=PESUM
2233           IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2234
2235 C...Check conservation of energy/momentum/flavour.
2236           PINI(1)=0D0
2237           PINI(2)=0D0
2238           PINI(3)=PZSUM
2239           PINI(4)=PESUMM
2240           PINI(6)=PQSUM
2241           DO 200 J=1,4
2242             PFIN(J)=PYP(0,J)
2243   200     CONTINUE
2244           PFIN(6)=PYP(0,6)
2245           MERR=0
2246           DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2247           DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2248           DEVQ=ABS(PFIN(6)-PINI(6))
2249           IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2250      &    DEVQ.GT.0.1D0) MERR=1
2251           IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2252      &    (PFIN(J),J=1,4),PFIN(6)
2253
2254 C...Check that all KF codes are known ones, and that partons/particles
2255 C...satisfy energy-momentum-mass relation.
2256           DO 210 I=1,N
2257             IF(K(I,1).GT.20) GOTO 210
2258             IF(PYCOMP(K(I,2)).EQ.0) THEN
2259               WRITE(MSTU(11),5100) I
2260               MERR=MERR+1
2261             ENDIF
2262             PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2263      &      SIGN(1D0,P(I,5))
2264             IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2265      &      .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2266               WRITE(MSTU(11),5200) I
2267               MERR=MERR+1
2268             ENDIF
2269   210     CONTINUE
2270
2271 C...Listing of erroneous events, and first event of each type.
2272           IF(MERR.GE.1) NERR=NERR+1
2273           IF(NERR.GE.10) THEN
2274             WRITE(MSTU(11),6300)
2275             CALL PYLIST(1)
2276             STOP
2277           ENDIF
2278           IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2279             IF(MERR.GE.1) WRITE(MSTU(11),6400)
2280             CALL PYLIST(1)
2281           ENDIF
2282   220   CONTINUE
2283
2284 C...List statistics for each process type.
2285         IF(MTEST.GE.1) CALL PYSTAT(1)
2286   230 CONTINUE
2287
2288 C...Summarize result of run.
2289       IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2290       IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2291
2292 C...Format statements for output.
2293  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2294      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2295      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2296      &4(1X,F12.5),1X,F8.2)
2297  5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2298  5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2299      &'kinematics')
2300  6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2301      &'wrong.'/5X,'Execution will be stopped after listing of event.')
2302  6400 FORMAT(5X,'Faulty event follows:')
2303  6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2304  6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2305      &5X,'This should not have happened!')
2306
2307       RETURN
2308       END
2309
2310 C*********************************************************************
2311
2312 C...PYHEPC
2313 C...Converts PYTHIA event record contents to or from
2314 C...the standard event record commonblock.
2315
2316       SUBROUTINE PYHEPC(MCONV)
2317
2318 C...Double precision and integer declarations.
2319       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2320       IMPLICIT INTEGER(I-N)
2321       INTEGER PYK,PYCHGE,PYCOMP
2322 C...Commonblocks.
2323       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2324       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2325       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2326       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2327 C...HEPEVT commonblock.
2328       PARAMETER (NMXHEP=4000)
2329       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2330      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2331       DOUBLE PRECISION PHEP,VHEP
2332       SAVE /HEPEVT/
2333
2334 C...Conversion from PYTHIA to standard, the easy part.
2335       IF(MCONV.EQ.1) THEN
2336         NEVHEP=0
2337         IF(N.GT.NMXHEP) CALL PYERRM(8,
2338      &  '(PYHEPC:) no more space in /HEPEVT/')
2339         NHEP=MIN(N,NMXHEP)
2340         DO 140 I=1,NHEP
2341           ISTHEP(I)=0
2342           IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2343           IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2344           IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2345           IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2346           IDHEP(I)=K(I,2)
2347           JMOHEP(1,I)=K(I,3)
2348           JMOHEP(2,I)=0
2349           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2350             JDAHEP(1,I)=K(I,4)
2351             JDAHEP(2,I)=K(I,5)
2352           ELSE
2353             JDAHEP(1,I)=0
2354             JDAHEP(2,I)=0
2355           ENDIF
2356           DO 100 J=1,5
2357             PHEP(J,I)=P(I,J)
2358   100     CONTINUE
2359           DO 110 J=1,4
2360             VHEP(J,I)=V(I,J)
2361   110     CONTINUE
2362
2363 C...Check if new event (from pileup).
2364           IF(I.EQ.1) THEN
2365             INEW=1
2366           ELSE
2367             IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2368           ENDIF
2369
2370 C...Fill in missing mother information.
2371           IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2372             IMO1=I-2
2373             IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
2374      &      IMO1=IMO1-1
2375             JMOHEP(1,I)=IMO1
2376             JMOHEP(2,I)=IMO1+1
2377           ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2378             I1=K(I,3)-1
2379   120       I1=I1+1
2380             IF(I1.GE.I) CALL PYERRM(8,
2381      &      '(PYHEPC:) translation of inconsistent event history')
2382             IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2383             KC=PYCOMP(K(I1,2))
2384             IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2385             IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2386             JMOHEP(2,I)=I1
2387           ELSEIF(K(I,2).EQ.94) THEN
2388             NJET=2
2389             IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2390             IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2391             JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2392             IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2393      &      MOD(K(I+1,4)/MSTU(5),MSTU(5))
2394           ENDIF
2395
2396 C...Fill in missing daughter information.
2397           IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2398             DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2399               I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2400               JDAHEP(1,I2)=I
2401   130       CONTINUE
2402           ENDIF
2403           IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2404           I1=JMOHEP(1,I)
2405           IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2406           IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2407           IF(JDAHEP(1,I1).EQ.0) THEN
2408             JDAHEP(1,I1)=I
2409           ELSE
2410             JDAHEP(2,I1)=I
2411           ENDIF
2412   140   CONTINUE
2413         DO 150 I=1,NHEP
2414           IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2415           IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2416   150   CONTINUE
2417
2418 C...Conversion from standard to PYTHIA, the easy part.
2419       ELSE
2420         IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2421      &  '(PYHEPC:) no more space in /PYJETS/')
2422         N=MIN(NHEP,MSTU(4))
2423         NKQ=0
2424         KQSUM=0
2425         DO 180 I=1,N
2426           K(I,1)=0
2427           IF(ISTHEP(I).EQ.1) K(I,1)=1
2428           IF(ISTHEP(I).EQ.2) K(I,1)=11
2429           IF(ISTHEP(I).EQ.3) K(I,1)=21
2430           K(I,2)=IDHEP(I)
2431           K(I,3)=JMOHEP(1,I)
2432           K(I,4)=JDAHEP(1,I)
2433           K(I,5)=JDAHEP(2,I)
2434           DO 160 J=1,5
2435             P(I,J)=PHEP(J,I)
2436   160     CONTINUE
2437           DO 170 J=1,4
2438             V(I,J)=VHEP(J,I)
2439   170     CONTINUE
2440           V(I,5)=0D0
2441           IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2442             I1=JDAHEP(1,I)
2443             IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2444      &      PHEP(5,I)/PHEP(4,I)
2445           ENDIF
2446
2447 C...Fill in missing information on colour connection in jet systems.
2448           IF(ISTHEP(I).EQ.1) THEN
2449             KC=PYCOMP(K(I,2))
2450             KQ=0
2451             IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2452             IF(KQ.NE.0) NKQ=NKQ+1
2453             IF(KQ.NE.2) KQSUM=KQSUM+KQ
2454             IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2455               K(I,1)=2
2456             ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2457               IF(K(I+1,2).EQ.21) K(I,1)=2
2458             ENDIF
2459           ENDIF
2460   180   CONTINUE
2461         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2462      &  '(PYHEPC:) input parton configuration not colour singlet')
2463       ENDIF
2464
2465       END
2466
2467 C*********************************************************************
2468
2469 C...PYINIT
2470 C...Initializes the generation procedure; finds maxima of the
2471 C...differential cross-sections to be used for weighting.
2472
2473       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2474
2475 C...Double precision and integer declarations.
2476       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2477       IMPLICIT INTEGER(I-N)
2478       INTEGER PYK,PYCHGE,PYCOMP
2479 C...Commonblocks.
2480       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2481       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2482       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2483       COMMON/PYDAT4/CHAF(500,2)
2484       CHARACTER CHAF*16
2485       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2486       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2487       COMMON/PYINT1/MINT(400),VINT(400)
2488       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2489       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2490       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2491      &/PYINT1/,/PYINT2/,/PYINT5/
2492 C...Local arrays and character variables.
2493       DIMENSION ALAMIN(20),NFIN(20)
2494       CHARACTER*(*) FRAME,BEAM,TARGET
2495       CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2496
2497 C...Interface to PDFLIB.
2498       COMMON/W50512/QCDL4,QCDL5
2499       SAVE /W50512/
2500       DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2501       CHARACTER*20 PARM(20)
2502       DATA VALUE/20*0D0/,PARM/20*' '/
2503
2504 C...Data:Lambda and n_f values for parton distributions..
2505       DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2506      &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2507      &NFIN/20*4/
2508       DATA CHLH/'lepton','hadron'/
2509
2510 C...Reset MINT and VINT arrays. Write headers.
2511       MSTI(53)=0
2512       DO 100 J=1,400
2513         MINT(J)=0
2514         VINT(J)=0D0
2515   100 CONTINUE
2516       IF(MSTU(12).GE.1) CALL PYLIST(0)
2517       IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2518
2519 C...Call user process initialization routine.
2520       IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2521         MSEL=0
2522         CALL UPINIT
2523         MSEL=0
2524       ENDIF
2525
2526 C...Maximum 4 generations; set maximum number of allowed flavours.
2527       MSTP(1)=MIN(4,MSTP(1))
2528       MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2529       MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2530
2531 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2532       DO 120 I=-20,20
2533         VINT(180+I)=0D0
2534         IA=IABS(I)
2535         IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2536           DO 110 J=1,MSTP(1)
2537             IB=2*J-1+MOD(IA,2)
2538             IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2539             IPM=(5-ISIGN(1,I))/2
2540             IDC=J+MDCY(IA,2)+2
2541             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2542      &      VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2543   110     CONTINUE
2544         ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2545           VINT(180+I)=1D0
2546         ENDIF
2547   120 CONTINUE
2548
2549 C...Initialize parton distributions: PDFLIB.
2550       IF(MSTP(52).EQ.2) THEN
2551         PARM(1)='NPTYPE'
2552         VALUE(1)=1
2553         PARM(2)='NGROUP'
2554         VALUE(2)=MSTP(51)/1000
2555         PARM(3)='NSET'
2556         VALUE(3)=MOD(MSTP(51),1000)
2557         PARM(4)='TMAS'
2558         VALUE(4)=PMAS(6,1)
2559 C.... ALICE
2560         CALL PDFSET_ALICE(PARM,VALUE)
2561         MINT(93)=1000000+MSTP(51)
2562       ENDIF
2563
2564 C...Choose Lambda value to use in alpha-strong.
2565       MSTU(111)=MSTP(2)
2566       IF(MSTP(3).GE.2) THEN
2567         ALAM=0.2D0
2568         NF=4
2569         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2570           ALAM=ALAMIN(MSTP(51))
2571           NF=NFIN(MSTP(51))
2572         ELSEIF(MSTP(52).EQ.2) THEN
2573           ALAM=QCDL4
2574           NF=4
2575         ENDIF
2576         PARP(1)=ALAM
2577         PARP(61)=ALAM
2578         PARP(72)=ALAM
2579         PARU(112)=ALAM
2580         MSTU(112)=NF
2581         IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2582       ENDIF
2583
2584 C...Initialize the SUSY generation: couplings, masses,
2585 C...decay modes, branching ratios, and so on.
2586       CALL PYMSIN
2587 C...Initialize widths and partial widths for resonances.
2588       CALL PYINRE
2589 C...Set Z0 mass and width for e+e- routines.
2590       PARJ(123)=PMAS(23,1)
2591       PARJ(124)=PMAS(23,2)
2592
2593 C...Identify beam and target particles and frame of process.
2594       CHFRAM=FRAME//' '
2595       CHBEAM=BEAM//' '
2596       CHTARG=TARGET//' '
2597       CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2598       IF(MINT(65).EQ.1) GOTO 170
2599
2600 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2601 C...For e-gamma allow 2 alternatives.
2602       MINT(121)=1
2603       IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2604         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2605      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2606         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2607         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2608      &  (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2609       ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2610         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2611      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2612         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2613       ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2614         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2615      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2616         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2617       ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2618         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2619      &  (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2620         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2621       ENDIF
2622       MINT(123)=MSTP(14)
2623       IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2624      &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2625       IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2626         IF(MSTP(14).EQ.11) MINT(123)=0
2627         IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2628         IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2629         IF(MSTP(14).EQ.15) MINT(123)=2
2630         IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2631         IF(MSTP(14).EQ.19) MINT(123)=3
2632       ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2633         IF(MSTP(14).EQ.21) MINT(123)=0
2634         IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2635         IF(MSTP(14).EQ.24) MINT(123)=1
2636       ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2637         IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2638         IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2639       ENDIF
2640
2641 C...Set up kinematics of process.
2642       CALL PYINKI(0)
2643
2644 C...Set up kinematics for photons inside leptons.
2645       IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2646
2647 C...Precalculate flavour selection weights.
2648       CALL PYKFIN
2649
2650 C...Loop over gamma-p or gamma-gamma alternatives.
2651       CKIN3=CKIN(3)
2652       MSAV48=0
2653       DO 160 IGA=1,MINT(121)
2654         CKIN(3)=CKIN3
2655         MINT(122)=IGA
2656
2657 C...Select partonic subprocesses to be included in the simulation.
2658         CALL PYINPR
2659         MINT(101)=1
2660         MINT(102)=1
2661         MINT(103)=MINT(11)
2662         MINT(104)=MINT(12)
2663
2664 C...Count number of subprocesses on.
2665         MINT(48)=0
2666         DO 130 ISUB=1,500
2667           IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2668      &    MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2669             MSUB(ISUB)=0
2670           ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2671      &    MSUB(ISUB).EQ.1) THEN
2672             WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2673             STOP
2674           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2675             WRITE(MSTU(11),5300) ISUB
2676             STOP
2677           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2678             WRITE(MSTU(11),5400) ISUB
2679             STOP
2680           ELSEIF(MSUB(ISUB).EQ.1) THEN
2681             MINT(48)=MINT(48)+1
2682           ENDIF
2683   130   CONTINUE
2684
2685 C...Stop or raise warning flag if no subprocesses on.
2686         IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2687           IF(MSTP(127).NE.1) THEN
2688             WRITE(MSTU(11),5500)
2689             STOP
2690           ELSE
2691             WRITE(MSTU(11),5700)
2692             MSTI(53)=1
2693           ENDIF
2694         ENDIF
2695         MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2696         MSAV48=MSAV48+MINT(48)
2697
2698 C...Reset variables for cross-section calculation.
2699         DO 150 I=0,500
2700           DO 140 J=1,3
2701             NGEN(I,J)=0
2702             XSEC(I,J)=0D0
2703   140     CONTINUE
2704   150   CONTINUE
2705
2706 C...Find parametrized total cross-sections.
2707         CALL PYXTOT
2708         VINT(318)=VINT(317)
2709
2710 C...Maxima of differential cross-sections.
2711         IF(MSTP(121).LE.1) CALL PYMAXI
2712
2713 C...Initialize possibility of pileup events.
2714         IF(MINT(121).GT.1) MSTP(131)=0
2715         IF(MSTP(131).NE.0) CALL PYPILE(1)
2716
2717 C...Initialize multiple interactions with variable impact parameter.
2718         IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2719      &  MSTP(82).GE.2) CALL PYMULT(1)
2720
2721 C...Save results for gamma-p and gamma-gamma alternatives.
2722         IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2723   160 CONTINUE
2724
2725 C...Initialization finished.
2726       IF(MSAV48.EQ.0) THEN
2727         IF(MSTP(127).NE.1) THEN
2728           WRITE(MSTU(11),5500)
2729           STOP
2730         ELSE
2731           WRITE(MSTU(11),5700)
2732           MSTI(53)=1
2733         ENDIF
2734       ENDIF
2735   170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2736
2737 C...Formats for initialization information.
2738  5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2739      &'routines',1X,17('*'))
2740  5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2741      &'-',A6,' interactions.'/1X,'Execution stopped!')
2742  5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2743      &1X,'Execution stopped!')
2744  5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2745      &1X,'Execution stopped!')
2746  5500 FORMAT(1X,'Error: no subprocess switched on.'/
2747      &1X,'Execution stopped.')
2748  5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2749      &22('*'))
2750  5700 FORMAT(1X,'Error: no subprocess switched on.'/
2751      &1X,'Execution will stop if you try to generate events.')
2752
2753       RETURN
2754       END
2755
2756 C*********************************************************************
2757
2758 C...PYEVNT
2759 C...Administers the generation of a high-pT event via calls to
2760 C...a number of subroutines.
2761
2762       SUBROUTINE PYEVNT
2763
2764 C...Double precision and integer declarations.
2765       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2766       IMPLICIT INTEGER(I-N)
2767       INTEGER PYK,PYCHGE,PYCOMP
2768 C...Commonblocks.
2769       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2770       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2771       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2772       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2773       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2774       COMMON/PYINT1/MINT(400),VINT(400)
2775       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2776       COMMON/PYINT4/MWID(500),WIDS(500,5)
2777       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2778       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2779      &/PYINT2/,/PYINT4/,/PYINT5/
2780 C...Local array.
2781       DIMENSION VTX(4)
2782
2783 C...Stop if no subprocesses on.
2784       IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2785         WRITE(MSTU(11),5100)
2786         STOP
2787       ENDIF
2788
2789 C...Initial values for some counters.
2790       N=0
2791       MINT(5)=MINT(5)+1
2792       MINT(7)=0
2793       MINT(8)=0
2794       MINT(83)=0
2795       MINT(84)=MSTP(126)
2796       MSTU(24)=0
2797       MSTU70=0
2798       MSTJ14=MSTJ(14)
2799
2800 C...If variable energies: redo incoming kinematics and cross-section.
2801       MSTI(61)=0
2802       IF(MSTP(171).EQ.1) THEN
2803         CALL PYINKI(1)
2804         IF(MSTI(61).EQ.1) THEN
2805           MINT(5)=MINT(5)-1
2806           RETURN
2807         ENDIF
2808         IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2809         CALL PYXTOT
2810       ENDIF
2811
2812 C...Loop over number of pileup events; check space left.
2813       IF(MSTP(131).LE.0) THEN
2814         NPILE=1
2815       ELSE
2816         CALL PYPILE(2)
2817         NPILE=MINT(81)
2818       ENDIF
2819       DO 250 IPILE=1,NPILE
2820         IF(MINT(84)+100.GE.MSTU(4)) THEN
2821           CALL PYERRM(11,
2822      &    '(PYEVNT:) no more space in PYJETS for pileup events')
2823           IF(MSTU(21).GE.1) GOTO 260
2824         ENDIF
2825         MINT(82)=IPILE
2826
2827 C...Generate variables of hard scattering.
2828         MINT(51)=0
2829         MSTI(52)=0
2830   100   CONTINUE
2831         IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2832         MINT(31)=0
2833         MINT(51)=0
2834         MINT(57)=0
2835         CALL PYRAND
2836         IF(MSTI(61).EQ.1) THEN
2837           MINT(5)=MINT(5)-1
2838           RETURN
2839         ENDIF
2840         IF(MINT(51).EQ.2) RETURN
2841         ISUB=MINT(1)
2842         IF(MSTP(111).EQ.-1) GOTO 240
2843
2844         IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2845 C...Hard scattering (including low-pT):
2846 C...reconstruct kinematics and colour flow of hard scattering.
2847           MINT31=MINT(31)
2848   110     MINT(31)=MINT31
2849           MINT(51)=0
2850           CALL PYSCAT
2851           IF(MINT(51).EQ.1) GOTO 100
2852           IPU1=MINT(84)+1
2853           IPU2=MINT(84)+2
2854           IF(ISUB.EQ.95) GOTO 120
2855
2856 C...Showering of initial state partons (optional).
2857           NFIN=N
2858           ALAMSV=PARJ(81)
2859           PARJ(81)=PARP(72)
2860           IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2861           PARJ(81)=ALAMSV
2862           IF(MINT(51).EQ.1) GOTO 100
2863
2864 C...Showering of final state partons (optional).
2865           ALAMSV=PARJ(81)
2866           PARJ(81)=PARP(72)
2867           IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2868      &    THEN
2869             IPU3=MINT(84)+3
2870             IPU4=MINT(84)+4
2871             IF(ISET(ISUB).EQ.5) IPU4=-3
2872             QMAX=VINT(55)
2873             IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2874             CALL PYSHOW(IPU3,IPU4,QMAX)
2875           ELSEIF(ISET(ISUB).EQ.11) THEN
2876             CALL PYADSH(NFIN)
2877           ENDIF
2878           PARJ(81)=ALAMSV
2879
2880 C...Decay of final state resonances.
2881           MINT(32)=0
2882           IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2883           IF(MINT(51).EQ.1) GOTO 100
2884           MINT(52)=N
2885
2886 C...Multiple interactions.
2887           IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2888           MINT(53)=N
2889
2890 C...Hadron remnants and primordial kT.
2891   120     CALL PYREMN(IPU1,IPU2)
2892           IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2893           IF(MINT(51).EQ.1) GOTO 100
2894
2895          ELSEIF(ISUB.NE.99) THEN
2896 C...Diffractive and elastic scattering.
2897           CALL PYDIFF
2898
2899         ELSE
2900 C...DIS scattering (photon flux external).
2901           CALL PYDISG
2902           IF(MINT(51).EQ.1) GOTO 100
2903         ENDIF
2904
2905 C...Check that no odd resonance left undecayed.
2906         IF(MSTP(111).GE.1) THEN
2907           NFIX=N
2908           DO 130 I=MINT(84)+1,NFIX
2909             IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2910      &      K(I,2).NE.22) THEN
2911               KCA=PYCOMP(K(I,2))
2912               IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2913                 CALL PYRESD(I)
2914                 IF(MINT(51).EQ.1) GOTO 100
2915               ENDIF
2916             ENDIF
2917   130     CONTINUE
2918         ENDIF
2919
2920 C...Boost hadronic subsystem to overall rest frame.
2921 C..(Only relevant when photon inside lepton beam.)
2922         IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2923
2924 C...Recalculate energies from momenta and masses (if desired).
2925         IF(MSTP(113).GE.1) THEN
2926           DO 140 I=MINT(83)+1,N
2927             IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2928      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
2929   140     CONTINUE
2930           NRECAL=N
2931         ENDIF
2932
2933 C...Rearrange partons along strings, check invariant mass cuts.
2934         MSTU(28)=0
2935         IF(MSTP(111).LE.0) MSTJ(14)=-1
2936         CALL PYPREP(MINT(84)+1)
2937         MSTJ(14)=MSTJ14
2938         IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2939         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2940           DO 170 I=MINT(84)+1,N
2941             IF(K(I,2).EQ.94) THEN
2942               DO 160 I1=I+1,MIN(N,I+3)
2943                 IF(K(I1,3).EQ.I) THEN
2944                   K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2945                   IF(K(I1,3).EQ.0) THEN
2946                     DO 150 II=MINT(84)+1,I-1
2947                         IF(K(II,2).EQ.K(I1,2)) THEN
2948                           IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2949      &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2950                         ENDIF
2951   150               CONTINUE
2952                     IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2953                   ENDIF
2954                 ENDIF
2955   160         CONTINUE
2956             ENDIF
2957   170     CONTINUE
2958           CALL PYEDIT(12)
2959           CALL PYEDIT(14)
2960           IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2961           IF(MSTP(125).EQ.0) MINT(4)=0
2962           DO 190 I=MINT(83)+1,N
2963             IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2964               DO 180 I1=I+1,N
2965                 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2966                 IF(K(I1,3).EQ.I) K(I,5)=I1
2967   180         CONTINUE
2968             ENDIF
2969   190     CONTINUE
2970         ENDIF
2971
2972 C...Introduce separators between sections in PYLIST event listing.
2973         IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2974           MSTU70=1
2975           MSTU(71)=N
2976         ELSEIF(IPILE.EQ.1) THEN
2977           MSTU70=3
2978           MSTU(71)=2
2979           MSTU(72)=MINT(4)
2980           MSTU(73)=N
2981         ENDIF
2982
2983 C...Go back to lab frame (needed for vertices, also in fragmentation).
2984         CALL PYFRAM(1)
2985
2986 C...Set nonvanishing production vertex (optional).
2987         IF(MSTP(151).EQ.1) THEN
2988           DO 200 J=1,4
2989             VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2990      &      SIN(PARU(2)*PYR(0))
2991   200     CONTINUE
2992           DO 220 I=MINT(83)+1,N
2993             DO 210 J=1,4
2994               V(I,J)=V(I,J)+VTX(J)
2995   210       CONTINUE
2996   220     CONTINUE
2997         ENDIF
2998
2999 C...Perform hadronization (if desired).
3000         IF(MSTP(111).GE.1) THEN
3001           CALL PYEXEC
3002           IF(MSTU(24).NE.0) GOTO 100
3003         ENDIF
3004         IF(MSTP(113).GE.1) THEN
3005           DO 230 I=NRECAL,N
3006             IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3007      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
3008   230     CONTINUE
3009         ENDIF
3010         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3011
3012 C...Store event information and calculate Monte Carlo estimates of
3013 C...subprocess cross-sections.
3014   240   IF(IPILE.EQ.1) CALL PYDOCU
3015
3016 C...Set counters for current pileup event and loop to next one.
3017         MSTI(41)=IPILE
3018         IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3019         IF(MSTU70.LT.10) THEN
3020           MSTU70=MSTU70+1
3021           MSTU(70+MSTU70)=N
3022         ENDIF
3023         MINT(83)=N
3024         MINT(84)=N+MSTP(126)
3025         IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3026   250 CONTINUE
3027
3028 C...Generic information on pileup events. Reconstruct missing history.
3029       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3030         PARI(91)=VINT(132)
3031         PARI(92)=VINT(133)
3032         PARI(93)=VINT(134)
3033         IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3034       ENDIF
3035       CALL PYEDIT(16)
3036
3037 C...Transform to the desired coordinate frame.
3038   260 CALL PYFRAM(MSTP(124))
3039       MSTU(70)=MSTU70
3040       PARU(21)=VINT(1)
3041
3042 C...Error messages
3043  5100 FORMAT(1X,'Error: no subprocess switched on.'/
3044      &1X,'Execution stopped.')
3045
3046       RETURN
3047       END
3048
3049 C***********************************************************************
3050
3051 C...PYSTAT
3052 C...Prints out information about cross-sections, decay widths, branching
3053 C...ratios, kinematical limits, status codes and parameter values.
3054
3055       SUBROUTINE PYSTAT(MSTAT)
3056
3057 C...Double precision and integer declarations.
3058       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3059       IMPLICIT INTEGER(I-N)
3060       INTEGER PYK,PYCHGE,PYCOMP
3061 C...Parameter statement to help give large particle numbers.
3062       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3063      &KEXCIT=4000000,KDIMEN=5000000)
3064       PARAMETER (EPS=1D-3)
3065 C...Commonblocks.
3066       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3067       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3068       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3069       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3070       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3071       COMMON/PYINT1/MINT(400),VINT(400)
3072       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3073       COMMON/PYINT4/MWID(500),WIDS(500,5)
3074       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3075       COMMON/PYINT6/PROC(0:500)
3076       CHARACTER PROC*28, CHTMP*16
3077       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3078       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3079       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3080      &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3081 C...Local arrays, character variables and data.
3082       DIMENSION WDTP(0:300),WDTE(0:300,0:5),NMODES(0:20),PBRAT(10)
3083       CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3084      &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3085      &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3086       CHARACTER*24 CHD0, CHDC(10)
3087       CHARACTER*6 DNAME(3)
3088       DATA PROGA/
3089      &'VMD/hadron * VMD            ','VMD/hadron * direct         ',
3090      &'VMD/hadron * anomalous      ','direct * direct             ',
3091      &'direct * anomalous          ','anomalous * anomalous       '/
3092       DATA DISGA/'e * VMD','e * anomalous'/
3093       DATA PROGG9/
3094      &'direct * direct             ','direct * VMD                ',
3095      &'direct * anomalous          ','VMD * direct                ',
3096      &'VMD * VMD                   ','VMD * anomalous             ',
3097      &'anomalous * direct          ','anomalous * VMD             ',
3098      &'anomalous * anomalous       ','DIS * VMD                   ',
3099      &'DIS * anomalous             ','VMD * DIS                   ',
3100      &'anomalous * DIS             '/
3101       DATA PROGG4/
3102      &'direct * direct             ','direct * resolved           ',
3103      &'resolved * direct           ','resolved * resolved         '/
3104       DATA PROGG2/
3105      &'direct * hadron             ','resolved * hadron           '/
3106       DATA PROGP4/
3107      &'VMD * hadron                ','direct * hadron             ',
3108      &'anomalous * hadron          ','DIS * hadron                '/
3109       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
3110      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3111      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
3112      &'     y*_small     ','    eta*_large    ','    eta*_small    ',
3113      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
3114      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
3115      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
3116      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
3117      &'       tau''       '/
3118       DATA DNAME /'q     ','lepton','nu    '/
3119
3120 C...Cross-sections.
3121       IF(MSTAT.LE.1) THEN
3122         IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3123         WRITE(MSTU(11),5000)
3124         WRITE(MSTU(11),5100)
3125         WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3126         DO 100 I=1,500
3127           IF(MSUB(I).NE.1) GOTO 100
3128           WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3129   100   CONTINUE
3130         IF(MINT(121).GT.1) THEN
3131           WRITE(MSTU(11),5300)
3132           DO 110 IGA=1,MINT(121)
3133             CALL PYSAVE(3,IGA)
3134             IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3135               WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3136      &        XSEC(0,3)
3137             ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3138               WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3139      &        XSEC(0,3)
3140             ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3141               WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3142      &        XSEC(0,3)
3143             ELSEIF(MINT(121).EQ.4) THEN
3144               WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3145      &        XSEC(0,3)
3146             ELSEIF(MINT(121).EQ.2) THEN
3147               WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3148      &        XSEC(0,3)
3149             ELSE
3150               WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3151      &        XSEC(0,3)
3152             ENDIF
3153   110     CONTINUE
3154           CALL PYSAVE(5,0)
3155         ENDIF
3156         WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3157      &  MAX(1D0,DBLE(NGEN(0,2)))
3158
3159 C...Decay widths and branching ratios.
3160       ELSEIF(MSTAT.EQ.2) THEN
3161         WRITE(MSTU(11),5500)
3162         WRITE(MSTU(11),5600)
3163         DO 140 KC=1,500
3164           KF=KCHG(KC,4)
3165           CALL PYNAME(KF,CHKF)
3166           IOFF=0
3167           IF(KC.LE.22) THEN
3168             IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3169             IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3170             IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3171             IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3172             IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3173           ELSE
3174             IF(MWID(KC).LE.0) GOTO 140
3175             IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3176      &      KF/KSUSY1.EQ.2)) GOTO 140
3177           ENDIF
3178 C...Off-shell branchings.
3179           IF(IOFF.EQ.1) THEN
3180             NGP=0
3181             IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3182             IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3183      &      PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3184             DO 120 J=1,MDCY(KC,3)
3185               IDC=J+MDCY(KC,2)-1
3186               NGP1=0
3187               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3188      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3189               NGP2=0
3190               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3191      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3192               CALL PYNAME(KFDP(IDC,1),CHD1)
3193               CALL PYNAME(KFDP(IDC,2),CHD2)
3194               IF(KFDP(IDC,3).EQ.0) THEN
3195                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3196      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3197      &          CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3198               ELSE
3199                 CALL PYNAME(KFDP(IDC,3),CHD3)
3200                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3201      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3202      &          CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3203               ENDIF
3204   120       CONTINUE
3205 C...On-shell decays.
3206           ELSE
3207             CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3208             BRFIN=1D0
3209             IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3210             WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3211      &      STATE(MDCY(KC,1)),BRFIN
3212             DO 130 J=1,MDCY(KC,3)
3213               IDC=J+MDCY(KC,2)-1
3214               NGP1=0
3215               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3216      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3217               NGP2=0
3218               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3219      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3220               BRFIN=0D0
3221               IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3222               CALL PYNAME(KFDP(IDC,1),CHD1)
3223               CALL PYNAME(KFDP(IDC,2),CHD2)
3224               IF(KFDP(IDC,3).EQ.0) THEN
3225                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3226      &          WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3227      &          CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3228      &          STATE(MDME(IDC,1)),BRFIN
3229               ELSE
3230                 CALL PYNAME(KFDP(IDC,3),CHD3)
3231                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3232      &          WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3233      &          CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3234      &          STATE(MDME(IDC,1)),BRFIN
3235               ENDIF
3236   130       CONTINUE
3237           ENDIF
3238   140   CONTINUE
3239         WRITE(MSTU(11),6000)
3240
3241 C...Allowed incoming partons/particles at hard interaction.
3242       ELSEIF(MSTAT.EQ.3) THEN
3243         WRITE(MSTU(11),6100)
3244         CALL PYNAME(MINT(11),CHAU)
3245         CHIN(1)=CHAU(1:12)
3246         CALL PYNAME(MINT(12),CHAU)
3247         CHIN(2)=CHAU(1:12)
3248         WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3249         DO 150 I=-20,22
3250           IF(I.EQ.0) GOTO 150
3251           IA=IABS(I)
3252           IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3253           IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3254           CALL PYNAME(I,CHAU)
3255           WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3256      &    STATE(KFIN(2,I))
3257   150   CONTINUE
3258         WRITE(MSTU(11),6400)
3259
3260 C...User-defined limits on kinematical variables.
3261       ELSEIF(MSTAT.EQ.4) THEN
3262         WRITE(MSTU(11),6500)
3263         WRITE(MSTU(11),6600)
3264         SHRMAX=CKIN(2)
3265         IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3266         WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3267         PTHMIN=MAX(CKIN(3),CKIN(5))
3268         PTHMAX=CKIN(4)
3269         IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3270         WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3271         WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3272         DO 160 I=4,14
3273           WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3274   160   CONTINUE
3275         SPRMAX=CKIN(32)
3276         IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3277         WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3278         WRITE(MSTU(11),7000)
3279
3280 C...Status codes and parameter values.
3281       ELSEIF(MSTAT.EQ.5) THEN
3282         WRITE(MSTU(11),7100)
3283         WRITE(MSTU(11),7200)
3284         DO 170 I=1,100
3285           WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3286      &    PARP(100+I)
3287   170   CONTINUE
3288
3289 C...List of all processes implemented in the program.
3290       ELSEIF(MSTAT.EQ.6) THEN
3291         WRITE(MSTU(11),7400)
3292         WRITE(MSTU(11),7500)
3293         DO 180 I=1,500
3294           IF(ISET(I).LT.0) GOTO 180
3295           WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3296   180   CONTINUE
3297         WRITE(MSTU(11),7700)
3298
3299       ELSEIF(MSTAT.EQ.7) THEN
3300       WRITE (MSTU(11),8000)
3301       NMODES(0)=0
3302       NMODES(10)=0
3303       NMODES(9)=0
3304       DO 290 ILR=1,2
3305         DO 280 KFSM=1,16
3306           KFSUSY=ILR*KSUSY1+KFSM
3307           NRVDC=0
3308 C...SDOWN DECAYS
3309           IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3310             NRVDC=2
3311             DO 190 I=1,NRVDC
3312               PBRAT(I)=0D0
3313               NMODES(I)=0
3314   190       CONTINUE
3315             CALL PYNAME(KFSUSY,CHTMP)
3316             CHD0=CHTMP//' '
3317             CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3318             CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3319             KC=PYCOMP(KFSUSY)
3320             DO 200 J=1,MDCY(KC,3)
3321               IDC=J+MDCY(KC,2)-1
3322               ID1=IABS(KFDP(IDC,1))
3323               ID2=IABS(KFDP(IDC,2))
3324               IF (KFDP(IDC,3).EQ.0) THEN
3325                 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3326      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3327                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
3328                   NMODES(1)=NMODES(1)+1
3329                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3330                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3331                 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3332      &                 .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3333                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
3334                   NMODES(2)=NMODES(2)+1
3335                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3336                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3337                 ENDIF
3338               ENDIF
3339   200       CONTINUE
3340           ENDIF
3341 C...SUP DECAYS
3342           IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3343             NRVDC=1
3344             DO 210 I=1,NRVDC
3345               NMODES(I)=0
3346               PBRAT(I)=0D0
3347   210       CONTINUE
3348             CALL PYNAME(KFSUSY,CHTMP)
3349             CHD0=CHTMP//' '
3350             CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3351             KC=PYCOMP(KFSUSY)
3352             DO 220 J=1,MDCY(KC,3)
3353               IDC=J+MDCY(KC,2)-1
3354               ID1=IABS(KFDP(IDC,1))
3355               ID2=IABS(KFDP(IDC,2))
3356               IF (KFDP(IDC,3).EQ.0) THEN
3357                 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3358      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3359                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
3360                   NMODES(1)=NMODES(1)+1
3361                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3362                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3363                 ENDIF
3364               ENDIF
3365   220       CONTINUE
3366           ENDIF
3367 C...SLEPTON DECAYS
3368           IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3369             NRVDC=2
3370             DO 230 I=1,NRVDC
3371               PBRAT(I)=0D0
3372               NMODES(I)=0
3373   230       CONTINUE
3374             CALL PYNAME(KFSUSY,CHTMP)
3375             CHD0=CHTMP//' '
3376             CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3377             CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3378             KC=PYCOMP(KFSUSY)
3379             DO 240 J=1,MDCY(KC,3)
3380               IDC=J+MDCY(KC,2)-1
3381               ID1=IABS(KFDP(IDC,1))
3382               ID2=IABS(KFDP(IDC,2))
3383               IF (KFDP(IDC,3).EQ.0) THEN
3384                 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3385      &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3386                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
3387                   NMODES(1)=NMODES(1)+1
3388                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3389                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3390                 ENDIF
3391                 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3392      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3393                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
3394                   NMODES(2)=NMODES(2)+1
3395                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3396                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3397                 ENDIF
3398               ENDIF
3399   240       CONTINUE
3400           ENDIF
3401 C...SNEUTRINO DECAYS
3402           IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3403      &         THEN
3404             NRVDC=2
3405             DO 250 I=1,NRVDC
3406               PBRAT(I)=0D0
3407               NMODES(I)=0
3408   250       CONTINUE
3409             CALL PYNAME(KFSUSY,CHTMP)
3410             CHD0=CHTMP//' '
3411             CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3412             CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3413             KC=PYCOMP(KFSUSY)
3414             DO 260 J=1,MDCY(KC,3)
3415               IDC=J+MDCY(KC,2)-1
3416               ID1=IABS(KFDP(IDC,1))
3417               ID2=IABS(KFDP(IDC,2))
3418               IF (KFDP(IDC,3).EQ.0) THEN
3419                 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3420      &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3421                   PBRAT(1)=PBRAT(1)+BRAT(IDC)
3422                   NMODES(1)=NMODES(1)+1
3423                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3424                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3425                 ENDIF
3426                 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3427      &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3428                   NMODES(2)=NMODES(2)+1
3429                   PBRAT(2)=PBRAT(2)+BRAT(IDC)
3430                   IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3431                   IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3432                 ENDIF
3433               ENDIF
3434   260       CONTINUE
3435           ENDIF
3436           IF (NRVDC.NE.0) THEN
3437             DO 270 I=1,NRVDC
3438               WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3439               NMODES(0)=NMODES(0)+NMODES(I)
3440   270       CONTINUE
3441           ENDIF
3442   280   CONTINUE
3443   290 CONTINUE
3444       DO 350 KFSM=22,37
3445         KFSUSY=KSUSY1+KFSM
3446         NRVDC=0
3447 C...NEUTRALINO DECAYS
3448         IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3449           NRVDC=3
3450           DO 300 I=1,NRVDC
3451             PBRAT(I)=0D0
3452             NMODES(I)=0
3453   300     CONTINUE
3454           CALL PYNAME(KFSUSY,CHTMP)
3455           CHD0=CHTMP//' '
3456           CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3457           CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3458           CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3459           KC=PYCOMP(KFSUSY)
3460           DO 310 J=1,MDCY(KC,3)
3461             IDC=J+MDCY(KC,2)-1
3462             ID1=IABS(KFDP(IDC,1))
3463             ID2=IABS(KFDP(IDC,2))
3464             ID3=IABS(KFDP(IDC,3))
3465             IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3466      &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3467      &           .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3468               PBRAT(1)=PBRAT(1)+BRAT(IDC)
3469               NMODES(1)=NMODES(1)+1
3470               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3471               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3472             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3473      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3474      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3475               PBRAT(2)=PBRAT(2)+BRAT(IDC)
3476               NMODES(2)=NMODES(2)+1
3477               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3478               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3479             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3480      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3481      &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3482               PBRAT(3)=PBRAT(3)+BRAT(IDC)
3483               NMODES(3)=NMODES(3)+1
3484               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3485               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3486             ENDIF
3487   310     CONTINUE
3488         ENDIF
3489 C...CHARGINO DECAYS
3490         IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3491           NRVDC=4
3492           DO 320 I=1,NRVDC
3493             PBRAT(I)=0D0
3494             NMODES(I)=0
3495   320     CONTINUE
3496           CALL PYNAME(KFSUSY,CHTMP)
3497           CHD0=CHTMP//' '
3498           CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3499           CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3500           CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3501           CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3502           KC=PYCOMP(KFSUSY)
3503           DO 330 J=1,MDCY(KC,3)
3504             IDC=J+MDCY(KC,2)-1
3505             ID1=IABS(KFDP(IDC,1))
3506             ID2=IABS(KFDP(IDC,2))
3507             ID3=IABS(KFDP(IDC,3))
3508             IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3509      &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3510      &           .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3511               PBRAT(1)=PBRAT(1)+BRAT(IDC)
3512               NMODES(1)=NMODES(1)+1
3513               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3514               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3515             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3516      &             .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3517      &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3518               PBRAT(1)=PBRAT(1)+BRAT(IDC)
3519               NMODES(1)=NMODES(1)+1
3520               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3521               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3522             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3523      &             .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3524      &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3525               PBRAT(2)=PBRAT(2)+BRAT(IDC)
3526               NMODES(2)=NMODES(2)+1
3527               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3528               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3529             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3530      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3531      &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3532               PBRAT(3)=PBRAT(3)+BRAT(IDC)
3533               NMODES(3)=NMODES(3)+1
3534               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3535               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3536             ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3537      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3538      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3539               PBRAT(3)=PBRAT(3)+BRAT(IDC)
3540               NMODES(3)=NMODES(3)+1
3541               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3542               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3543             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3544      &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3545      &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3546               PBRAT(4)=PBRAT(4)+BRAT(IDC)
3547               NMODES(4)=NMODES(4)+1
3548               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3549               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3550             ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3551      &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3552      &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3553               PBRAT(4)=PBRAT(4)+BRAT(IDC)
3554               NMODES(4)=NMODES(4)+1
3555               IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3556               IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3557             ENDIF
3558   330     CONTINUE
3559         ENDIF
3560         IF (NRVDC.NE.0) THEN
3561           DO 340 I=1,NRVDC
3562             WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3563             NMODES(0)=NMODES(0)+NMODES(I)
3564   340     CONTINUE
3565         ENDIF
3566   350 CONTINUE
3567       WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3568
3569       IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
3570         WRITE (MSTU(11),8500)
3571         DO 380 IRV=1,3
3572           DO 370 JRV=1,3
3573             DO 360 KRV=1,3
3574               WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3575      &             ,RVLAMP(IRV,JRV,KRV), 0D0
3576   360       CONTINUE
3577   370     CONTINUE
3578   380   CONTINUE
3579         WRITE (MSTU(11),8600)
3580       ENDIF
3581
3582
3583       ENDIF
3584
3585 C...Formats for printouts.
3586  5000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ',
3587      &'Events and Cross-sections',1X,9('*'))
3588  5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3589      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3590      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3591      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3592      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3593      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3594      &'I',12X,'I')
3595  5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3596      &D10.3,1X,'I')
3597  5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3598      &1X,'I',34X,'I',28X,'I',12X,'I')
3599  5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3600      &1X,'********* Fraction of events that fail fragmentation ',
3601      &'cuts =',1X,F8.5,' *********'/)
3602  5500 FORMAT('1',27('*'),1X,'PYSTAT:  Decay Widths and Branching ',
3603      &'Ratios',1X,27('*'))
3604  5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3605      &1X,'I',5X,'Mother  -->  Branching/Decay Channel',8X,'I',1X,
3606      &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3607      &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3608      &1X,98('='))
3609  5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3610      &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3611      &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3612  5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3613      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3614      &1P,D10.3,0P,1X,'I')
3615  5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3616      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3617      &1P,D10.3,0P,1X,'I')
3618  6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3619  6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3620      &'Particles at Hard Interaction',1X,7('*'))
3621  6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3622      &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3623      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3624      &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3625      &78('=')/1X,'I',38X,'I',37X,'I')
3626  6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3627  6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3628  6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3629      &'Kinematical Variables',1X,12('*'))
3630  6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3631  6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3632      &16X,'I')
3633  6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3634      &1X,'<',1X,1P,D10.3,0P,16X,'I')
3635  6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3636  7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3637  7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3638      &'Parameter Values',1X,12('*'))
3639  7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3640      &'PARP(I)'/)
3641  7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3642  7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3643      &1X,13('*'))
3644  7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3645      &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3646      &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3647  7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3648  7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3649  8000 FORMAT(1X/ 1X/
3650      &     17X,'Sums over R-Violating branching ratios',1X/ 1X
3651      &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3652      &     ,'Mother  -->  Sum over final state flavours',4X,'I',2X
3653      &     ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3654      &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3655  8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3656      &     ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3657      &     1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3658      &     ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3659      &     /1X,70('='))
3660  8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3661      &     'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3662  8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3663  8500 FORMAT(1X/ 1X/
3664      &     1X,'R-Violating couplings',1X/ 1X /
3665      &     1X,55('=')/
3666      &     1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3667      &     ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3668      &     ,'I',15X,'I',15X,'I',15X,'I')
3669  8600 FORMAT(1X,55('='))
3670  8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3671      &     ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3672
3673       RETURN
3674       END
3675
3676 C*********************************************************************
3677
3678 C...PYINRE
3679 C...Calculates full and effective widths of gauge bosons, stores
3680 C...masses and widths, rescales coefficients to be used for
3681 C...resonance production generation.
3682
3683       SUBROUTINE PYINRE
3684
3685 C...Double precision and integer declarations.
3686       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3687       IMPLICIT INTEGER(I-N)
3688       INTEGER PYK,PYCHGE,PYCOMP
3689 C...Parameter statement to help give large particle numbers.
3690       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3691      &KEXCIT=4000000,KDIMEN=5000000)
3692 C...Commonblocks.
3693       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3694       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3695       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3696       COMMON/PYDAT4/CHAF(500,2)
3697       CHARACTER CHAF*16
3698       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3699       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3700       COMMON/PYINT1/MINT(400),VINT(400)
3701       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3702       COMMON/PYINT4/MWID(500),WIDS(500,5)
3703       COMMON/PYINT6/PROC(0:500)
3704       CHARACTER PROC*28
3705       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3706       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3707      &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3708 C...Local arrays and data.
3709       DIMENSION WDTP(0:300),WDTE(0:300,0:5),WDTPM(0:300),
3710      &WDTEM(0:300,0:5),KCORD(500),PMORD(500)
3711
3712 C...Born level couplings in MSSM Higgs doublet sector.
3713       XW=PARU(102)
3714       XWV=XW
3715       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3716       XW1=1D0-XW
3717       IF(MSTP(4).EQ.2) THEN
3718         TANBE=PARU(141)
3719         RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3720         SQMZ=PMAS(23,1)**2
3721         SQMW=PMAS(24,1)**2
3722         SQMH=PMAS(25,1)**2
3723         SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3724         SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3725         SQMHC=SQMA+SQMW
3726         IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3727           WRITE(MSTU(11),5000)
3728           STOP
3729         ENDIF
3730         PMAS(35,1)=SQRT(SQMHP)
3731         PMAS(36,1)=SQRT(SQMA)
3732         PMAS(37,1)=SQRT(SQMHC)
3733         ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3734      &  (SQMA-SQMZ)))
3735         BESU=ATAN(TANBE)
3736         PARU(142)=1D0
3737         PARU(143)=1D0
3738         PARU(161)=-SIN(ALSU)/COS(BESU)
3739         PARU(162)=COS(ALSU)/SIN(BESU)
3740         PARU(163)=PARU(161)
3741         PARU(164)=SIN(BESU-ALSU)
3742         PARU(165)=PARU(164)
3743         PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3744         PARU(171)=COS(ALSU)/COS(BESU)
3745         PARU(172)=SIN(ALSU)/SIN(BESU)
3746         PARU(173)=PARU(171)
3747         PARU(174)=COS(BESU-ALSU)
3748         PARU(175)=PARU(174)
3749         PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3750      &  SIN(BESU+ALSU)
3751         PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3752         PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3753         PARU(181)=TANBE
3754         PARU(182)=1D0/TANBE
3755         PARU(183)=PARU(181)
3756         PARU(184)=0D0
3757         PARU(185)=PARU(184)
3758         PARU(186)=COS(BESU-ALSU)
3759         PARU(187)=SIN(BESU-ALSU)
3760         PARU(188)=PARU(186)
3761         PARU(189)=PARU(187)
3762         PARU(190)=0D0
3763         PARU(195)=COS(BESU-ALSU)
3764       ENDIF
3765
3766 C...Reset effective widths of gauge bosons.
3767       DO 110 I=1,500
3768         DO 100 J=1,5
3769           WIDS(I,J)=1D0
3770   100   CONTINUE
3771   110 CONTINUE
3772
3773 C...Order resonances by increasing mass (except Z0 and W+/-).
3774       NRES=0
3775       DO 140 KC=1,500
3776         KF=KCHG(KC,4)
3777         IF(KF.EQ.0) GOTO 140
3778         IF(MWID(KC).EQ.0) GOTO 140
3779         IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3780           IF(MSTP(1).LE.3) GOTO 140
3781         ENDIF
3782         IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3783           IF(IMSS(1).LE.0) GOTO 140
3784         ENDIF
3785         NRES=NRES+1
3786         PMRES=PMAS(KC,1)
3787         IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3788         DO 120 I1=NRES-1,1,-1
3789           IF(PMRES.GE.PMORD(I1)) GOTO 130
3790           KCORD(I1+1)=KCORD(I1)
3791           PMORD(I1+1)=PMORD(I1)
3792   120   CONTINUE
3793   130   KCORD(I1+1)=KC
3794         PMORD(I1+1)=PMRES
3795   140 CONTINUE
3796
3797 C...Loop over possible resonances.
3798       DO 180 I=1,NRES
3799         KC=KCORD(I)
3800         KF=KCHG(KC,4)
3801
3802 C...Check that no fourth generation channels on by mistake.
3803         IF(MSTP(1).LE.3) THEN
3804           DO 150 J=1,MDCY(KC,3)
3805             IDC=J+MDCY(KC,2)-1
3806             KFA1=IABS(KFDP(IDC,1))
3807             KFA2=IABS(KFDP(IDC,2))
3808             IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3809      &      KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3810      &      MDME(IDC,1)=-1
3811   150     CONTINUE
3812         ENDIF
3813
3814 C...Check that no supersymmetric channels on by mistake.
3815         IF(IMSS(1).LE.0) THEN
3816           DO 160 J=1,MDCY(KC,3)
3817             IDC=J+MDCY(KC,2)-1
3818             KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3819             KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3820             IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3821      &      MDME(IDC,1)=-1
3822   160     CONTINUE
3823         ENDIF
3824
3825 C...Find mass and evaluate width.
3826         PMR=PMAS(KC,1)
3827         IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3828         IF(MWID(KC).EQ.3) MINT(63)=1
3829         CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3830         MINT(51)=0
3831
3832 C...Evaluate suppression factors due to non-simulated channels.
3833         IF(KCHG(KC,3).EQ.0) THEN
3834           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3835      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3836      &    2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3837           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3838           WIDS(KC,3)=0D0
3839           WIDS(KC,4)=0D0
3840           WIDS(KC,5)=0D0
3841         ELSE
3842           IF(MWID(KC).EQ.3) MINT(63)=1
3843           CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3844           MINT(51)=0
3845           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3846      &    (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3847      &    (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3848      &    WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3849           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3850           WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3851           WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3852      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3853      &    2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3854           WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3855      &    2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3856      &    2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3857         ENDIF
3858
3859 C...Set resonance widths and branching ratios;
3860 C...also on/off switch for decays.
3861         IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3862           PMAS(KC,2)=WDTP(0)
3863           PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3864           IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
3865           DO 170 J=1,MDCY(KC,3)
3866             IDC=J+MDCY(KC,2)-1
3867             BRAT(IDC)=0D0
3868             IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3869   170     CONTINUE
3870         ENDIF
3871   180 CONTINUE
3872
3873 C...Flavours of leptoquark: redefine charge and name.
3874       KFLQQ=KFDP(MDCY(42,2),1)
3875       KFLQL=KFDP(MDCY(42,2),2)
3876       KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3877      &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3878       LL=1
3879       IF(IABS(KFLQL).EQ.13) LL=2
3880       IF(IABS(KFLQL).EQ.15) LL=3
3881       CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3882      &CHAF(IABS(KFLQL),1)(1:LL)//' '
3883       CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
3884
3885 C...Special cases in treatment of gamma*/Z0: redefine process name.
3886       IF(MSTP(43).EQ.1) THEN
3887         PROC(1)='f + fbar -> gamma*'
3888         PROC(15)='f + fbar -> g + gamma*'
3889         PROC(19)='f + fbar -> gamma + gamma*'
3890         PROC(30)='f + g -> f + gamma*'
3891         PROC(35)='f + gamma -> f + gamma*'
3892       ELSEIF(MSTP(43).EQ.2) THEN
3893         PROC(1)='f + fbar -> Z0'
3894         PROC(15)='f + fbar -> g + Z0'
3895         PROC(19)='f + fbar -> gamma + Z0'
3896         PROC(30)='f + g -> f + Z0'
3897         PROC(35)='f + gamma -> f + Z0'
3898       ELSEIF(MSTP(43).EQ.3) THEN
3899         PROC(1)='f + fbar -> gamma*/Z0'
3900         PROC(15)='f + fbar -> g + gamma*/Z0'
3901         PROC(19)='f + fbar -> gamma + gamma*/Z0'
3902         PROC(30)='f + g -> f + gamma*/Z0'
3903         PROC(35)='f + gamma -> f + gamma*/Z0'
3904       ENDIF
3905
3906 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3907       IF(MSTP(44).EQ.1) THEN
3908         PROC(141)='f + fbar -> gamma*'
3909       ELSEIF(MSTP(44).EQ.2) THEN
3910         PROC(141)='f + fbar -> Z0'
3911       ELSEIF(MSTP(44).EQ.3) THEN
3912         PROC(141)='f + fbar -> Z''0'
3913       ELSEIF(MSTP(44).EQ.4) THEN
3914         PROC(141)='f + fbar -> gamma*/Z0'
3915       ELSEIF(MSTP(44).EQ.5) THEN
3916         PROC(141)='f + fbar -> gamma*/Z''0'
3917       ELSEIF(MSTP(44).EQ.6) THEN
3918         PROC(141)='f + fbar -> Z0/Z''0'
3919       ELSEIF(MSTP(44).EQ.7) THEN
3920         PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3921       ENDIF
3922
3923 C...Special cases in treatment of WW -> WW: redefine process name.
3924       IF(MSTP(45).EQ.1) THEN
3925         PROC(77)='W+ + W+ -> W+ + W+'
3926       ELSEIF(MSTP(45).EQ.2) THEN
3927         PROC(77)='W+ + W- -> W+ + W-'
3928       ELSEIF(MSTP(45).EQ.3) THEN
3929         PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3930       ENDIF
3931
3932 C...Format for error information.
3933  5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3934      &'combination'/1X,'Execution stopped!')
3935
3936       RETURN
3937       END
3938
3939 C*********************************************************************
3940
3941 C...PYINBM
3942 C...Identifies the two incoming particles and the choice of frame.
3943
3944        SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3945
3946 C...Double precision and integer declarations.
3947       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3948       IMPLICIT INTEGER(I-N)
3949       INTEGER PYK,PYCHGE,PYCOMP
3950
3951 C...User process initialization commonblock.
3952       INTEGER MAXPUP
3953       PARAMETER (MAXPUP=100)
3954       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
3955       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
3956       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
3957      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
3958      &LPRUP(MAXPUP)
3959       SAVE /HEPRUP/
3960
3961 C...Commonblocks.
3962       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3963       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3964       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3965       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3966       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3967       COMMON/PYINT1/MINT(400),VINT(400)
3968       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3969
3970 C...Local arrays, character variables and data.
3971       CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3972      &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
3973       DIMENSION LEN(3),KCDE(39),PM(2)
3974       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3975      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3976       DATA CHCDE/    'e-          ','e+          ','nu_e        ',
3977      &'nu_ebar     ','mu-         ','mu+         ','nu_mu       ',
3978      &'nu_mubar    ','tau-        ','tau+        ','nu_tau      ',
3979      &'nu_taubar   ','pi+         ','pi-         ','n0          ',
3980      &'nbar0       ','p+          ','pbar-       ','gamma       ',
3981      &'lambda0     ','sigma-      ','sigma0      ','sigma+      ',
3982      &'xi-         ','xi0         ','omega-      ','pi0         ',
3983      &'reggeon     ','pomeron     ','gamma/e-    ','gamma/e+    ',
3984      &'gamma/mu-   ','gamma/mu+   ','gamma/tau-  ','gamma/tau+  ',
3985      &'k+          ','k-          ','ks0         ','kl0         '/
3986       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3987      &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3988      &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
3989
3990 C...Store initial energy. Default frame.
3991       VINT(290)=WIN
3992       MINT(111)=0
3993
3994 C...Special user process initialization; convert to normal input.
3995       IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
3996         MINT(111)=11
3997         CALL PYNAME(IDBMUP(1),CHNAME)
3998         CHBEAM=CHNAME(1:12)
3999         CALL PYNAME(IDBMUP(2),CHNAME)
4000         CHTARG=CHNAME(1:12)
4001       ENDIF
4002
4003 C...Convert character variables to lowercase and find their length.
4004       CHCOM(1)=CHFRAM
4005       CHCOM(2)=CHBEAM
4006       CHCOM(3)=CHTARG
4007       DO 130 I=1,3
4008         LEN(I)=12
4009         DO 110 LL=12,1,-1
4010           IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4011           DO 100 LA=1,26
4012             IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4013      &      CHALP(1)(LA:LA)
4014   100     CONTINUE
4015   110   CONTINUE
4016         CHIDNT(I)=CHCOM(I)
4017
4018 C...Fix up bar, underscore and charge in particle name (if needed).
4019         DO 120 LL=1,10
4020           IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4021             CHTEMP=CHIDNT(I)
4022             CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//'  '
4023           ENDIF
4024   120   CONTINUE
4025         IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4026           CHTEMP=CHIDNT(I)
4027           CHIDNT(I)='nu_'//CHTEMP(3:7)
4028         ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4029           CHIDNT(I)(1:3)='n0 '
4030         ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4031           CHIDNT(I)(1:5)='nbar0'
4032         ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4033           CHIDNT(I)(1:3)='p+ '
4034         ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4035      &    CHIDNT(I)(1:2).EQ.'p-') THEN
4036           CHIDNT(I)(1:5)='pbar-'
4037         ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4038           CHIDNT(I)(7:7)='0'
4039         ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4040           CHIDNT(I)(1:7)='reggeon'
4041         ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4042           CHIDNT(I)(1:7)='pomeron'
4043         ENDIF
4044   130 CONTINUE
4045
4046 C...Identify free initialization.
4047       IF(CHCOM(1)(1:2).EQ.'no') THEN
4048         MINT(65)=1
4049         RETURN
4050       ENDIF
4051
4052 C...Identify incoming beam and target particles.
4053       DO 160 I=1,2
4054         DO 140 J=1,39
4055           IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4056   140   CONTINUE
4057         PM(I)=PYMASS(MINT(10+I))
4058         VINT(2+I)=PM(I)
4059         MINT(140+I)=0
4060         IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4061           CHTEMP=CHIDNT(I+1)(7:12)//' '
4062           DO 150 J=1,12
4063             IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4064   150     CONTINUE
4065           PM(I)=PYMASS(MINT(140+I))
4066           VINT(302+I)=PM(I)
4067         ENDIF
4068   160 CONTINUE
4069       IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4070       IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4071       IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4072
4073 C...Identify choice of frame and input energies.
4074       CHINIT=' '
4075
4076 C...Events defined in the CM frame.
4077       IF(CHCOM(1)(1:2).EQ.'cm') THEN
4078         MINT(111)=1
4079         S=WIN**2
4080         IF(MSTP(122).GE.1) THEN
4081           IF(CHCOM(2)(1:1).NE.'e') THEN
4082             LOFFS=(31-(LEN(2)+LEN(3)))/2
4083             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4084      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4085      &      ' collider'//' '
4086           ELSE
4087             LOFFS=(30-(LEN(2)+LEN(3)))/2
4088             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4089      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4090      &      ' collider'//' '
4091           ENDIF
4092           WRITE(MSTU(11),5200) CHINIT
4093           WRITE(MSTU(11),5300) WIN
4094         ENDIF
4095
4096 C...Events defined in fixed target frame.
4097       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4098         MINT(111)=2
4099         S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4100         IF(MSTP(122).GE.1) THEN
4101           LOFFS=(29-(LEN(2)+LEN(3)))/2
4102           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4103      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4104      &    ' fixed target'//' '
4105           WRITE(MSTU(11),5200) CHINIT
4106           WRITE(MSTU(11),5400) WIN
4107           WRITE(MSTU(11),5500) SQRT(S)
4108         ENDIF
4109
4110 C...Frame defined by user three-vectors.
4111       ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4112         MINT(111)=3
4113         P(1,5)=PM(1)
4114         P(2,5)=PM(2)
4115         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4116         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4117         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4118      &  (P(1,3)+P(2,3))**2
4119         IF(MSTP(122).GE.1) THEN
4120           LOFFS=(22-(LEN(2)+LEN(3)))/2
4121           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4122      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4123      &    ' user configuration'//' '
4124           WRITE(MSTU(11),5200) CHINIT
4125           WRITE(MSTU(11),5600)
4126           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4127           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4128           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4129         ENDIF
4130
4131 C...Frame defined by user four-vectors.
4132       ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4133         MINT(111)=4
4134         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4135         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4136         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4137         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4138         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4139      &  (P(1,3)+P(2,3))**2
4140         IF(MSTP(122).GE.1) THEN
4141           LOFFS=(22-(LEN(2)+LEN(3)))/2
4142           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4143      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4144      &    ' user configuration'//' '
4145           WRITE(MSTU(11),5200) CHINIT
4146           WRITE(MSTU(11),5600)
4147           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4148           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4149           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4150         ENDIF
4151
4152 C...Frame defined by user five-vectors.
4153       ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4154         MINT(111)=5
4155         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4156      &  (P(1,3)+P(2,3))**2
4157         IF(MSTP(122).GE.1) THEN
4158           LOFFS=(22-(LEN(2)+LEN(3)))/2
4159           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4160      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4161      &    ' user configuration'//' '
4162           WRITE(MSTU(11),5200) CHINIT
4163           WRITE(MSTU(11),5600)
4164           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4165           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4166           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4167         ENDIF
4168
4169 C...Frame defined by HEPRUP common block.
4170       ELSEIF(MINT(111).EQ.11) THEN
4171         S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4172      &  SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4173         IF(MSTP(122).GE.1) THEN
4174           LOFFS=(22-(LEN(2)+LEN(3)))/2
4175           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4176      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4177      &    ' user configuration'//' '
4178           WRITE(MSTU(11),5200) CHINIT
4179           WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4180           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4181         ENDIF
4182
4183 C...Unknown frame. Error for too low CM energy.
4184       ELSE
4185         WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4186         STOP
4187       ENDIF
4188       IF(S.LT.PARP(2)**2) THEN
4189         WRITE(MSTU(11),5900) SQRT(S)
4190         STOP
4191       ENDIF
4192
4193 C...Formats for initialization and error information.
4194  5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4195      &1X,'Execution stopped!')
4196  5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4197      &1X,'Execution stopped!')
4198  5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4199  5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4200      &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4201  5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4202  5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4203      &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4204  5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4205      &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4206  5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4207  5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4208      &1X,'Execution stopped!')
4209  5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4210      &'generation.'/1X,'Execution stopped!')
4211  6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4212      &'GeV beam energies',13X,'I')
4213
4214       RETURN
4215       END
4216
4217 C*********************************************************************
4218
4219 C...PYINKI
4220 C...Sets up kinematics, including rotations and boosts to/from CM frame.
4221
4222       SUBROUTINE PYINKI(MODKI)
4223
4224 C...Double precision and integer declarations.
4225       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4226       IMPLICIT INTEGER(I-N)
4227       INTEGER PYK,PYCHGE,PYCOMP
4228
4229 C...User process initialization commonblock.
4230       INTEGER MAXPUP
4231       PARAMETER (MAXPUP=100)
4232       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4233       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4234       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4235      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4236      &LPRUP(MAXPUP)
4237       SAVE /HEPRUP/
4238
4239 C...Commonblocks.
4240       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4241       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4242       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4243       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4244       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4245       COMMON/PYINT1/MINT(400),VINT(400)
4246       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4247
4248 C...Set initial flavour state.
4249       N=2
4250       DO 100 I=1,2
4251         K(I,1)=1
4252         K(I,2)=MINT(10+I)
4253         IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4254   100 CONTINUE
4255
4256 C...Reset boost. Do kinematics for various cases.
4257       DO 110 J=6,10
4258         VINT(J)=0D0
4259   110 CONTINUE
4260
4261 C...Set up kinematics for events defined in CM frame.
4262       IF(MINT(111).EQ.1) THEN
4263         WIN=VINT(290)
4264         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4265         S=WIN**2
4266         P(1,5)=VINT(3)
4267         P(2,5)=VINT(4)
4268         IF(MINT(141).NE.0) P(1,5)=VINT(303)
4269         IF(MINT(142).NE.0) P(2,5)=VINT(304)
4270         P(1,1)=0D0
4271         P(1,2)=0D0
4272         P(2,1)=0D0
4273         P(2,2)=0D0
4274         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4275      &  (4D0*S))
4276         P(2,3)=-P(1,3)
4277         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4278         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4279
4280 C...Set up kinematics for fixed target events.
4281       ELSEIF(MINT(111).EQ.2) THEN
4282         WIN=VINT(290)
4283         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4284         P(1,5)=VINT(3)
4285         P(2,5)=VINT(4)
4286         IF(MINT(141).NE.0) P(1,5)=VINT(303)
4287         IF(MINT(142).NE.0) P(2,5)=VINT(304)
4288         P(1,1)=0D0
4289         P(1,2)=0D0
4290         P(2,1)=0D0
4291         P(2,2)=0D0
4292         P(1,3)=WIN
4293         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4294         P(2,3)=0D0
4295         P(2,4)=P(2,5)
4296         S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4297         VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4298         CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4299
4300 C...Set up kinematics for events in user-defined frame.
4301       ELSEIF(MINT(111).EQ.3) THEN
4302         P(1,5)=VINT(3)
4303         P(2,5)=VINT(4)
4304         IF(MINT(141).NE.0) P(1,5)=VINT(303)
4305         IF(MINT(142).NE.0) P(2,5)=VINT(304)
4306         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4307         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4308         DO 120 J=1,3
4309           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4310   120   CONTINUE
4311         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4312         VINT(7)=PYANGL(P(1,1),P(1,2))
4313         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4314         VINT(6)=PYANGL(P(1,3),P(1,1))
4315         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4316         S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4317
4318 C...Set up kinematics for events with user-defined four-vectors.
4319       ELSEIF(MINT(111).EQ.4) THEN
4320         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4321         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4322         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4323         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4324         DO 130 J=1,3
4325           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4326   130   CONTINUE
4327         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4328         VINT(7)=PYANGL(P(1,1),P(1,2))
4329         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4330         VINT(6)=PYANGL(P(1,3),P(1,1))
4331         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4332         S=(P(1,4)+P(2,4))**2
4333
4334 C...Set up kinematics for events with user-defined five-vectors.
4335       ELSEIF(MINT(111).EQ.5) THEN
4336         DO 140 J=1,3
4337           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4338   140   CONTINUE
4339         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4340         VINT(7)=PYANGL(P(1,1),P(1,2))
4341         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4342         VINT(6)=PYANGL(P(1,3),P(1,1))
4343         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4344         S=(P(1,4)+P(2,4))**2
4345
4346 C...Set up kinematics for events with external user processes.
4347       ELSEIF(MINT(111).EQ.11) THEN
4348         P(1,5)=VINT(3)
4349         P(2,5)=VINT(4)
4350         IF(MINT(141).NE.0) P(1,5)=VINT(303)
4351         IF(MINT(142).NE.0) P(2,5)=VINT(304)
4352         P(1,1)=0D0
4353         P(1,2)=0D0
4354         P(2,1)=0D0
4355         P(2,2)=0D0
4356         P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4357         P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4358         P(1,4)=EBMUP(1)
4359         P(2,4)=EBMUP(2)
4360         VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4361         CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4362         S=(P(1,4)+P(2,4))**2
4363       ENDIF
4364
4365 C...Return or error for too low CM energy.
4366       IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4367         IF(MSTP(172).LE.1) THEN
4368           CALL PYERRM(23,
4369      &    '(PYINKI:) too low invariant mass in this event')
4370         ELSE
4371           MSTI(61)=1
4372           RETURN
4373         ENDIF
4374       ENDIF
4375
4376 C...Save information on incoming particles.
4377       VINT(1)=SQRT(S)
4378       VINT(2)=S
4379       IF(MINT(111).GE.4) THEN
4380         IF(MINT(141).EQ.0) THEN
4381           VINT(3)=P(1,5)
4382           IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4383         ELSE
4384           VINT(303)=P(1,5)
4385         ENDIF
4386         IF(MINT(142).EQ.0) THEN
4387           VINT(4)=P(2,5)
4388           IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4389         ELSE
4390           VINT(304)=P(2,5)
4391         ENDIF
4392       ENDIF
4393       VINT(5)=P(1,3)
4394       IF(MODKI.EQ.0) VINT(289)=S
4395       DO 150 J=1,5
4396         V(1,J)=0D0
4397         V(2,J)=0D0
4398         VINT(290+J)=P(1,J)
4399         VINT(295+J)=P(2,J)
4400   150 CONTINUE
4401
4402 C...Store pT cut-off and related constants to be used in generation.
4403       IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4404       IF(MSTP(82).LE.1) THEN
4405         PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4406       ELSE
4407         PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4408       ENDIF
4409       VINT(149)=4D0*PTMN**2/S
4410       VINT(154)=PTMN
4411
4412       RETURN
4413       END
4414
4415 C*********************************************************************
4416
4417 C...PYINPR
4418 C...Selects partonic subprocesses to be included in the simulation.
4419
4420       SUBROUTINE PYINPR
4421
4422 C...Double precision and integer declarations.
4423       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4424       IMPLICIT INTEGER(I-N)
4425       INTEGER PYK,PYCHGE,PYCOMP
4426
4427 C...User process initialization commonblock.
4428       INTEGER MAXPUP
4429       PARAMETER (MAXPUP=100)
4430       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4431       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4432       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4433      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4434      &LPRUP(MAXPUP)
4435       SAVE /HEPRUP/
4436
4437 C...Commonblocks and character variables.
4438       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4439       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4440       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4441       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4442       COMMON/PYINT1/MINT(400),VINT(400)
4443       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4444       COMMON/PYINT6/PROC(0:500)
4445       CHARACTER PROC*28
4446       SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4447      &/PYINT6/
4448       CHARACTER CHIPR*10
4449
4450 C...Reset processes to be included.
4451       IF(MSEL.NE.0) THEN
4452         DO 100 I=1,500
4453           MSUB(I)=0
4454   100   CONTINUE
4455       ENDIF
4456
4457 C...Set running pTmin scale.
4458       IF(MSTP(82).LE.1) THEN
4459         PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4460       ELSE
4461         PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4462       ENDIF
4463
4464 C...Begin by assuming incoming photon to enter subprocess.
4465       IF(MINT(11).EQ.22) MINT(15)=22
4466       IF(MINT(12).EQ.22) MINT(16)=22
4467
4468 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4469       IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4470         MSUB(10)=1
4471         MINT(123)=MINT(122)+1
4472
4473 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4474 C...allow mixture.
4475 C...Here also set a few parameters otherwise normally not touched.
4476       ELSEIF(MINT(121).GT.1) THEN
4477
4478 C...Parton distributions dampened at small Q2; go to low energies,
4479 C...alpha_s <1; no minimum pT cut-off a priori.
4480         IF(MSTP(18).EQ.2) THEN
4481           MSTP(57)=3
4482           PARP(2)=2D0
4483           PARU(115)=1D0
4484           CKIN(5)=0.2D0
4485           CKIN(6)=0.2D0
4486         ENDIF
4487
4488 C...Define pT cut-off parameters and whether run involves low-pT.
4489         PTMVMD=PTMRUN
4490         VINT(154)=PTMVMD
4491         PTMDIR=PTMVMD
4492         IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4493         PTMANO=PTMVMD
4494         IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4495      &  0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4496         IPTL=1
4497         IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4498         IF(MSEL.EQ.2) IPTL=1
4499
4500 C...Set up for p/gamma * gamma; real or virtual photons.
4501         IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4502      &  MSTP(14).EQ.30)) THEN
4503
4504 C...Set up for p/VMD * VMD.
4505         IF(MINT(122).EQ.1) THEN
4506           MINT(123)=2
4507           MSUB(11)=1
4508           MSUB(12)=1
4509           MSUB(13)=1
4510           MSUB(28)=1
4511           MSUB(53)=1
4512           MSUB(68)=1
4513           IF(IPTL.EQ.1) MSUB(95)=1
4514           IF(MSEL.EQ.2) THEN
4515             MSUB(91)=1
4516             MSUB(92)=1
4517             MSUB(93)=1
4518             MSUB(94)=1
4519           ENDIF
4520           IF(IPTL.EQ.1) CKIN(3)=0D0
4521
4522 C...Set up for p/VMD * direct gamma.
4523         ELSEIF(MINT(122).EQ.2) THEN
4524           MINT(123)=0
4525           IF(MINT(121).EQ.6) MINT(123)=5
4526           MSUB(131)=1
4527           MSUB(132)=1
4528           MSUB(135)=1
4529           MSUB(136)=1
4530           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4531
4532 C...Set up for p/VMD * anomalous gamma.
4533         ELSEIF(MINT(122).EQ.3) THEN
4534           MINT(123)=3
4535           IF(MINT(121).EQ.6) MINT(123)=7
4536           MSUB(11)=1
4537           MSUB(12)=1
4538           MSUB(13)=1
4539           MSUB(28)=1
4540           MSUB(53)=1
4541           MSUB(68)=1
4542           IF(IPTL.EQ.1) MSUB(95)=1
4543           IF(MSEL.EQ.2) THEN
4544             MSUB(91)=1
4545             MSUB(92)=1
4546             MSUB(93)=1
4547             MSUB(94)=1
4548           ENDIF
4549           IF(IPTL.EQ.1) CKIN(3)=0D0
4550
4551 C...Set up for DIS * p.
4552         ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4553      &  IABS(MINT(12)).GT.100)) THEN
4554           MINT(123)=8
4555           IF(IPTL.EQ.1) MSUB(99)=1
4556
4557 C...Set up for direct * direct gamma (switch off leptons).
4558         ELSEIF(MINT(122).EQ.4) THEN
4559           MINT(123)=0
4560           MSUB(137)=1
4561           MSUB(138)=1
4562           MSUB(139)=1
4563           MSUB(140)=1
4564           DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4565             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4566   110     CONTINUE
4567           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4568
4569 C...Set up for direct * anomalous gamma.
4570         ELSEIF(MINT(122).EQ.5) THEN
4571           MINT(123)=6
4572           MSUB(131)=1
4573           MSUB(132)=1
4574           MSUB(135)=1
4575           MSUB(136)=1
4576           IF(IPTL.EQ.1) CKIN(3)=PTMANO
4577
4578 C...Set up for anomalous * anomalous gamma.
4579         ELSEIF(MINT(122).EQ.6) THEN
4580           MINT(123)=3
4581           MSUB(11)=1
4582           MSUB(12)=1
4583           MSUB(13)=1
4584           MSUB(28)=1
4585           MSUB(53)=1
4586           MSUB(68)=1
4587           IF(IPTL.EQ.1) MSUB(95)=1
4588           IF(MSEL.EQ.2) THEN
4589             MSUB(91)=1
4590             MSUB(92)=1
4591             MSUB(93)=1
4592             MSUB(94)=1
4593           ENDIF
4594           IF(IPTL.EQ.1) CKIN(3)=0D0
4595         ENDIF
4596
4597 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4598         ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4599
4600 C...Set up for direct * direct gamma (switch off leptons).
4601         IF(MINT(122).EQ.1) THEN
4602           MINT(123)=0
4603           MSUB(137)=1
4604           MSUB(138)=1
4605           MSUB(139)=1
4606           MSUB(140)=1
4607           DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4608             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4609   120     CONTINUE
4610           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4611
4612 C...Set up for direct * VMD and VMD * direct gamma.
4613         ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4614           MINT(123)=5
4615           MSUB(131)=1
4616           MSUB(132)=1
4617           MSUB(135)=1
4618           MSUB(136)=1
4619           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4620
4621 C...Set up for direct * anomalous and anomalous * direct gamma.
4622         ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4623           MINT(123)=6
4624           MSUB(131)=1
4625           MSUB(132)=1
4626           MSUB(135)=1
4627           MSUB(136)=1
4628           IF(IPTL.EQ.1) CKIN(3)=PTMANO
4629
4630 C...Set up for VMD*VMD.
4631         ELSEIF(MINT(122).EQ.5) THEN
4632           MINT(123)=2
4633           MSUB(11)=1
4634           MSUB(12)=1
4635           MSUB(13)=1
4636           MSUB(28)=1
4637           MSUB(53)=1
4638           MSUB(68)=1
4639           IF(IPTL.EQ.1) MSUB(95)=1
4640           IF(MSEL.EQ.2) THEN
4641             MSUB(91)=1
4642             MSUB(92)=1
4643             MSUB(93)=1
4644             MSUB(94)=1
4645           ENDIF
4646           IF(IPTL.EQ.1) CKIN(3)=0D0
4647
4648 C...Set up for VMD * anomalous and anomalous * VMD gamma.
4649         ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4650           MINT(123)=7
4651           MSUB(11)=1
4652           MSUB(12)=1
4653           MSUB(13)=1
4654           MSUB(28)=1
4655           MSUB(53)=1
4656           MSUB(68)=1
4657           IF(IPTL.EQ.1) MSUB(95)=1
4658           IF(MSEL.EQ.2) THEN
4659             MSUB(91)=1
4660             MSUB(92)=1
4661             MSUB(93)=1
4662             MSUB(94)=1
4663           ENDIF
4664           IF(IPTL.EQ.1) CKIN(3)=0D0
4665
4666 C...Set up for anomalous * anomalous gamma.
4667         ELSEIF(MINT(122).EQ.9) THEN
4668           MINT(123)=3
4669           MSUB(11)=1
4670           MSUB(12)=1
4671           MSUB(13)=1
4672           MSUB(28)=1
4673           MSUB(53)=1
4674           MSUB(68)=1
4675           IF(IPTL.EQ.1) MSUB(95)=1
4676           IF(MSEL.EQ.2) THEN
4677             MSUB(91)=1
4678             MSUB(92)=1
4679             MSUB(93)=1
4680             MSUB(94)=1
4681           ENDIF
4682           IF(IPTL.EQ.1) CKIN(3)=0D0
4683
4684 C...Set up for DIS * VMD and VMD * DIS gamma.
4685         ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4686           MINT(123)=8
4687           IF(IPTL.EQ.1) MSUB(99)=1
4688
4689 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4690         ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4691           MINT(123)=9
4692           IF(IPTL.EQ.1) MSUB(99)=1
4693         ENDIF
4694
4695 C...Set up for gamma* * p; virtual photons = dir, res.
4696         ELSEIF(MINT(121).EQ.2) THEN
4697
4698 C...Set up for direct * p.
4699         IF(MINT(122).EQ.1) THEN
4700           MINT(123)=0
4701           MSUB(131)=1
4702           MSUB(132)=1
4703           MSUB(135)=1
4704           MSUB(136)=1
4705           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4706
4707 C...Set up for resolved * p.
4708         ELSEIF(MINT(122).EQ.2) THEN
4709           MINT(123)=1
4710           MSUB(11)=1
4711           MSUB(12)=1
4712           MSUB(13)=1
4713           MSUB(28)=1
4714           MSUB(53)=1
4715           MSUB(68)=1
4716           IF(IPTL.EQ.1) MSUB(95)=1
4717           IF(MSEL.EQ.2) THEN
4718             MSUB(91)=1
4719             MSUB(92)=1
4720             MSUB(93)=1
4721             MSUB(94)=1
4722           ENDIF
4723           IF(IPTL.EQ.1) CKIN(3)=0D0
4724         ENDIF
4725
4726 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4727         ELSEIF(MINT(121).EQ.4) THEN
4728
4729 C...Set up for direct * direct gamma (switch off leptons).
4730         IF(MINT(122).EQ.1) THEN
4731           MINT(123)=0
4732           MSUB(137)=1
4733           MSUB(138)=1
4734           MSUB(139)=1
4735           MSUB(140)=1
4736           DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4737             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4738   130     CONTINUE
4739           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4740
4741 C...Set up for direct * resolved and resolved * direct gamma.
4742         ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4743           MINT(123)=5
4744           MSUB(131)=1
4745           MSUB(132)=1
4746           MSUB(135)=1
4747           MSUB(136)=1
4748           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4749
4750 C...Set up for resolved * resolved gamma.
4751         ELSEIF(MINT(122).EQ.4) THEN
4752           MINT(123)=2
4753           MSUB(11)=1
4754           MSUB(12)=1
4755           MSUB(13)=1
4756           MSUB(28)=1
4757           MSUB(53)=1
4758           MSUB(68)=1
4759           IF(IPTL.EQ.1) MSUB(95)=1
4760           IF(MSEL.EQ.2) THEN
4761             MSUB(91)=1
4762             MSUB(92)=1
4763             MSUB(93)=1
4764             MSUB(94)=1
4765           ENDIF
4766           IF(IPTL.EQ.1) CKIN(3)=0D0
4767         ENDIF
4768
4769 C...End of special set up for gamma-p and gamma-gamma.
4770         ENDIF
4771         CKIN(1)=2D0*CKIN(3)
4772       ENDIF
4773
4774 C...Flavour information for individual beams.
4775       DO 140 I=1,2
4776         MINT(40+I)=1
4777         IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4778         IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4779         MINT(44+I)=MINT(40+I)
4780         IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4781      &  IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4782   140 CONTINUE
4783
4784 C...If two real gammas, whereof one direct, pick the first.
4785 C...For two virtual photons, keep requested order.
4786       IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4787         IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4788           MINT(41)=1
4789           MINT(45)=1
4790         ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4791      &  MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4792           MINT(41)=1
4793           MINT(45)=1
4794         ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4795      &  MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4796           MINT(42)=1
4797           MINT(46)=1
4798         ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4799      &  .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4800           MINT(41)=1
4801           MINT(45)=1
4802         ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4803      &  .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4804           MINT(42)=1
4805           MINT(46)=1
4806         ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4807           MINT(41)=1
4808           MINT(45)=1
4809         ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4810           MINT(42)=1
4811           MINT(46)=1
4812         ENDIF
4813       ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4814         IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4815           IF(MINT(11).EQ.22) THEN
4816             MINT(41)=1
4817             MINT(45)=1
4818           ELSE
4819             MINT(42)=1
4820             MINT(46)=1
4821           ENDIF
4822         ENDIF
4823         IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4824      &  '(PYINPR:) unallowed MSTP(14) code for single photon')
4825       ENDIF
4826
4827 C...Flavour information on combination of incoming particles.
4828       MINT(43)=2*MINT(41)+MINT(42)-2
4829       MINT(44)=MINT(43)
4830       IF(MINT(123).LE.0) THEN
4831         IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4832         IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4833       ELSEIF(MINT(123).LE.3) THEN
4834         IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4835         IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4836       ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4837         MINT(43)=4
4838         MINT(44)=1
4839       ENDIF
4840       MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4841       IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4842       IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4843       IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4844       MINT(50)=0
4845       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4846       MINT(107)=0
4847       MINT(108)=0
4848       IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4849         IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
4850      &  MINT(107)=2
4851         IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
4852      &  MINT(107)=3
4853         IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
4854         IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
4855      &  MINT(122).EQ.10) MINT(108)=2
4856         IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
4857      &  MINT(122).EQ.11) MINT(108)=3
4858         IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
4859       ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
4860         IF(MINT(122).GE.3) MINT(107)=1
4861         IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
4862       ELSEIF(MINT(121).EQ.2) THEN
4863         IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
4864         IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
4865       ELSE
4866         IF(MINT(11).EQ.22) THEN
4867           MINT(107)=MINT(123)
4868           IF(MINT(123).GE.4) MINT(107)=0
4869           IF(MINT(123).EQ.7) MINT(107)=2
4870           IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
4871           IF(MSTP(14).EQ.28) MINT(107)=2
4872           IF(MSTP(14).EQ.29) MINT(107)=3
4873           IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4874      &    MINT(107)=4
4875         ENDIF
4876         IF(MINT(12).EQ.22) THEN
4877           MINT(108)=MINT(123)
4878           IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
4879           IF(MINT(123).EQ.7) MINT(108)=3
4880           IF(MSTP(14).EQ.26) MINT(108)=2
4881           IF(MSTP(14).EQ.27) MINT(108)=3
4882           IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
4883           IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4884      &    MINT(108)=4
4885         ENDIF
4886         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
4887      &  MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
4888           MINTTP=MINT(107)
4889           MINT(107)=MINT(108)
4890           MINT(108)=MINTTP
4891         ENDIF
4892       ENDIF
4893       IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
4894       IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
4895
4896 C...Select default processes according to incoming beams
4897 C...(already done for gamma-p and gamma-gamma with
4898 C...MSTP(14) = 10, 20, 25 or 30).
4899       IF(MINT(121).GT.1) THEN
4900       ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
4901
4902         IF(MINT(43).EQ.1) THEN
4903 C...Lepton + lepton -> gamma/Z0 or W.
4904           IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
4905           IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
4906
4907         ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
4908      &    (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
4909 C...Unresolved photon + lepton: Compton scattering.
4910           MSUB(133)=1
4911           MSUB(134)=1
4912
4913         ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
4914      &  .OR.MINT(12).EQ.22)) THEN
4915 C...DIS as pure gamma* + f -> f process.
4916           MSUB(99)=1
4917
4918         ELSEIF(MINT(43).LE.3) THEN
4919 C...Lepton + hadron: deep inelastic scattering.
4920           MSUB(10)=1
4921
4922         ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
4923      &    MINT(12).EQ.22) THEN
4924 C...Two unresolved photons: fermion pair production,
4925 C...exclude lepton pairs.
4926           DO 150 ISUB=137,140
4927             MSUB(ISUB)=1
4928   150     CONTINUE
4929           DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4930             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4931   160     CONTINUE
4932           PTMDIR=PTMRUN
4933           IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4934           IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
4935           CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
4936
4937         ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
4938      &    .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
4939      &    MINT(12).EQ.22)) THEN
4940 C...Unresolved photon + hadron: photon-parton scattering.
4941           DO 170 ISUB=131,136
4942             MSUB(ISUB)=1
4943   170     CONTINUE
4944
4945         ELSEIF(MSEL.EQ.1) THEN
4946 C...High-pT QCD processes:
4947           MSUB(11)=1
4948           MSUB(12)=1
4949           MSUB(13)=1
4950           MSUB(28)=1
4951           MSUB(53)=1
4952           MSUB(68)=1
4953           PTMN=PTMRUN
4954           VINT(154)=PTMN
4955           IF(CKIN(3).LT.PTMN) MSUB(95)=1
4956           IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
4957
4958         ELSE
4959 C...All QCD processes:
4960           MSUB(11)=1
4961           MSUB(12)=1
4962           MSUB(13)=1
4963           MSUB(28)=1
4964           MSUB(53)=1
4965           MSUB(68)=1
4966           MSUB(91)=1
4967           MSUB(92)=1
4968           MSUB(93)=1
4969           MSUB(94)=1
4970           MSUB(95)=1
4971         ENDIF
4972
4973       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
4974 C...Heavy quark production.
4975         MSUB(81)=1
4976         MSUB(82)=1
4977         MSUB(84)=1
4978         DO 180 J=1,MIN(8,MDCY(21,3))
4979           MDME(MDCY(21,2)+J-1,1)=0
4980   180   CONTINUE
4981         MDME(MDCY(21,2)+MSEL-1,1)=1
4982         MSUB(85)=1
4983         DO 190 J=1,MIN(12,MDCY(22,3))
4984           MDME(MDCY(22,2)+J-1,1)=0
4985   190   CONTINUE
4986         MDME(MDCY(22,2)+MSEL-1,1)=1
4987
4988       ELSEIF(MSEL.EQ.10) THEN
4989 C...Prompt photon production:
4990         MSUB(14)=1
4991         MSUB(18)=1
4992         MSUB(29)=1
4993
4994       ELSEIF(MSEL.EQ.11) THEN
4995 C...Z0/gamma* production:
4996         MSUB(1)=1
4997
4998       ELSEIF(MSEL.EQ.12) THEN
4999 C...W+/- production:
5000         MSUB(2)=1
5001
5002       ELSEIF(MSEL.EQ.13) THEN
5003 C...Z0 + jet:
5004         MSUB(15)=1
5005         MSUB(30)=1
5006
5007       ELSEIF(MSEL.EQ.14) THEN
5008 C...W+/- + jet:
5009         MSUB(16)=1
5010         MSUB(31)=1
5011
5012       ELSEIF(MSEL.EQ.15) THEN
5013 C...Z0 & W+/- pair production:
5014         MSUB(19)=1
5015         MSUB(20)=1
5016         MSUB(22)=1
5017         MSUB(23)=1
5018         MSUB(25)=1
5019
5020       ELSEIF(MSEL.EQ.16) THEN
5021 C...h0 production:
5022         MSUB(3)=1
5023         MSUB(102)=1
5024         MSUB(103)=1
5025         MSUB(123)=1
5026         MSUB(124)=1
5027
5028       ELSEIF(MSEL.EQ.17) THEN
5029 C...h0 & Z0 or W+/- pair production:
5030         MSUB(24)=1
5031         MSUB(26)=1
5032
5033       ELSEIF(MSEL.EQ.18) THEN
5034 C...h0 production; interesting processes in e+e-.
5035         MSUB(24)=1
5036         MSUB(103)=1
5037         MSUB(123)=1
5038         MSUB(124)=1
5039
5040       ELSEIF(MSEL.EQ.19) THEN
5041 C...h0, H0 and A0 production; interesting processes in e+e-.
5042         MSUB(24)=1
5043         MSUB(103)=1
5044         MSUB(123)=1
5045         MSUB(124)=1
5046         MSUB(153)=1
5047         MSUB(171)=1
5048         MSUB(173)=1
5049         MSUB(174)=1
5050         MSUB(158)=1
5051         MSUB(176)=1
5052         MSUB(178)=1
5053         MSUB(179)=1
5054
5055       ELSEIF(MSEL.EQ.21) THEN
5056 C...Z'0 production:
5057         MSUB(141)=1
5058
5059       ELSEIF(MSEL.EQ.22) THEN
5060 C...W'+/- production:
5061         MSUB(142)=1
5062
5063       ELSEIF(MSEL.EQ.23) THEN
5064 C...H+/- production:
5065         MSUB(143)=1
5066
5067       ELSEIF(MSEL.EQ.24) THEN
5068 C...R production:
5069         MSUB(144)=1
5070
5071       ELSEIF(MSEL.EQ.25) THEN
5072 C...LQ (leptoquark) production.
5073         MSUB(145)=1
5074         MSUB(162)=1
5075         MSUB(163)=1
5076         MSUB(164)=1
5077
5078       ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5079 C...Production of one heavy quark (W exchange):
5080         MSUB(83)=1
5081         DO 200 J=1,MIN(8,MDCY(21,3))
5082           MDME(MDCY(21,2)+J-1,1)=0
5083   200   CONTINUE
5084         MDME(MDCY(21,2)+MSEL-31,1)=1
5085
5086 CMRENNA++Define SUSY alternatives.
5087       ELSEIF(MSEL.EQ.39) THEN
5088 C...Turn on all SUSY processes.
5089         IF(MINT(43).EQ.4) THEN
5090 C...Hadron-hadron processes.
5091           DO 210 I=201,301
5092             IF(ISET(I).GE.0) MSUB(I)=1
5093   210     CONTINUE
5094         ELSEIF(MINT(43).EQ.1) THEN
5095 C...Lepton-lepton processes: QED production of squarks.
5096           DO 220 I=201,214
5097             MSUB(I)=1
5098   220     CONTINUE
5099           MSUB(210)=0
5100           MSUB(211)=0
5101           MSUB(212)=0
5102           DO 230 I=216,228
5103             MSUB(I)=1
5104   230     CONTINUE
5105           DO 240 I=261,263
5106             MSUB(I)=1
5107   240     CONTINUE
5108           MSUB(277)=1
5109           MSUB(278)=1
5110         ENDIF
5111
5112       ELSEIF(MSEL.EQ.40) THEN
5113 C...Gluinos and squarks.
5114         IF(MINT(43).EQ.4) THEN
5115           MSUB(243)=1
5116           MSUB(244)=1
5117           MSUB(258)=1
5118           MSUB(259)=1
5119           MSUB(261)=1
5120           MSUB(262)=1
5121           MSUB(264)=1
5122           MSUB(265)=1
5123           DO 250 I=271,296
5124             MSUB(I)=1
5125   250     CONTINUE
5126         ELSEIF(MINT(43).EQ.1) THEN
5127           MSUB(277)=1
5128           MSUB(278)=1
5129         ENDIF
5130
5131       ELSEIF(MSEL.EQ.41) THEN
5132 C...Stop production.
5133         MSUB(261)=1
5134         MSUB(262)=1
5135         MSUB(263)=1
5136         IF(MINT(43).EQ.4) THEN
5137           MSUB(264)=1
5138           MSUB(265)=1
5139         ENDIF
5140
5141       ELSEIF(MSEL.EQ.42) THEN
5142 C...Slepton production.
5143         DO 260 I=201,214
5144           MSUB(I)=1
5145   260   CONTINUE
5146         IF(MINT(43).NE.4) THEN
5147           MSUB(210)=0
5148           MSUB(211)=0
5149           MSUB(212)=0
5150         ENDIF
5151
5152       ELSEIF(MSEL.EQ.43) THEN
5153 C...Neutralino/Chargino + Gluino/Squark.
5154         IF(MINT(43).EQ.4) THEN
5155           DO 270 I=237,242
5156             MSUB(I)=1
5157   270     CONTINUE
5158           DO 280 I=246,257
5159             MSUB(I)=1
5160   280     CONTINUE
5161         ENDIF
5162
5163       ELSEIF(MSEL.EQ.44) THEN
5164 C...Neutralino/Chargino pair production.
5165         IF(MINT(43).EQ.4) THEN
5166           DO 290 I=216,236
5167             MSUB(I)=1
5168   290     CONTINUE
5169         ELSEIF(MINT(43).EQ.1) THEN
5170           DO 300 I=216,228
5171             MSUB(I)=1
5172   300     CONTINUE
5173         ENDIF
5174
5175       ELSEIF(MSEL.EQ.45) THEN
5176 C...Sbottom production.
5177         MSUB(287)=1
5178         MSUB(288)=1
5179         IF(MINT(43).EQ.4) THEN
5180           DO 310 I=281,296
5181             MSUB(I)=1
5182   310     CONTINUE
5183         ENDIF
5184
5185       ELSEIF(MSEL.EQ.50) THEN
5186         DO 320 I=361,368
5187           MSUB(I)=1
5188   320   CONTINUE
5189         IF(MINT(43).EQ.4) THEN
5190           DO 330 I=370,377
5191             MSUB(I)=1
5192   330     CONTINUE
5193         ENDIF
5194
5195       ENDIF
5196
5197 C...Find heaviest new quark flavour allowed in processes 81-84.
5198       KFLQM=1
5199       DO 340 I=1,MIN(8,MDCY(21,3))
5200         IDC=I+MDCY(21,2)-1
5201         IF(MDME(IDC,1).LE.0) GOTO 340
5202         KFLQM=I
5203   340 CONTINUE
5204       IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5205      &KFLQM=MSTP(7)
5206       MINT(55)=KFLQM
5207       KFPR(81,1)=KFLQM
5208       KFPR(81,2)=KFLQM
5209       KFPR(82,1)=KFLQM
5210       KFPR(82,2)=KFLQM
5211       KFPR(83,1)=KFLQM
5212       KFPR(84,1)=KFLQM
5213       KFPR(84,2)=KFLQM
5214
5215 C...Find heaviest new fermion flavour allowed in process 85.
5216       KFLFM=1
5217       DO 350 I=1,MIN(12,MDCY(22,3))
5218         IDC=I+MDCY(22,2)-1
5219         IF(MDME(IDC,1).LE.0) GOTO 350
5220         KFLFM=KFDP(IDC,1)
5221   350 CONTINUE
5222       IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5223      &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5224       MINT(56)=KFLFM
5225       KFPR(85,1)=KFLFM
5226       KFPR(85,2)=KFLFM
5227
5228 C...Import relevant information on external user processes.
5229       IF(MINT(111).EQ.11) THEN
5230         IPYPR=0
5231         DO 380 IUP=1,NPRUP
5232 C...Find next empty PYTHIA process number slot and enable it.
5233   360     IPYPR=IPYPR+1
5234           IF(IPYPR.GT.500) CALL PYERRM(26,
5235      &    '(PYINPR.) no more empty slots for user processes')
5236           IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 360
5237           ISET(IPYPR)=11
5238 C...Overwrite KFPR with references back to process number and ID.
5239           KFPR(IPYPR,1)=IUP
5240           KFPR(IPYPR,2)=LPRUP(IUP)
5241 C...Process title.
5242           WRITE(CHIPR,'(I10)') LPRUP(IUP)
5243           ICHIN=1
5244           DO 370 ICH=1,9
5245             IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5246   370     CONTINUE
5247           PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5248 C...Switch on process.
5249           MSUB(IPYPR)=1
5250   380   CONTINUE
5251       ENDIF
5252
5253       RETURN
5254       END
5255
5256 C*********************************************************************
5257
5258 C...PYXTOT
5259 C...Parametrizes total, elastic and diffractive cross-sections
5260 C...for different energies and beams. Donnachie-Landshoff for
5261 C...total and Schuler-Sjostrand for elastic and diffractive.
5262 C...Process code IPROC:
5263 C...=  1 : p + p;
5264 C...=  2 : pbar + p;
5265 C...=  3 : pi+ + p;
5266 C...=  4 : pi- + p;
5267 C...=  5 : pi0 + p;
5268 C...=  6 : phi + p;
5269 C...=  7 : J/psi + p;
5270 C...= 11 : rho + rho;
5271 C...= 12 : rho + phi;
5272 C...= 13 : rho + J/psi;
5273 C...= 14 : phi + phi;
5274 C...= 15 : phi + J/psi;
5275 C...= 16 : J/psi + J/psi;
5276 C...= 21 : gamma + p (DL);
5277 C...= 22 : gamma + p (VDM).
5278 C...= 23 : gamma + pi (DL);
5279 C...= 24 : gamma + pi (VDM);
5280 C...= 25 : gamma + gamma (DL);
5281 C...= 26 : gamma + gamma (VDM).
5282
5283       SUBROUTINE PYXTOT
5284
5285 C...Double precision and integer declarations.
5286       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5287       IMPLICIT INTEGER(I-N)
5288       INTEGER PYK,PYCHGE,PYCOMP
5289 C...Commonblocks.
5290       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5291       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5292       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5293       COMMON/PYINT1/MINT(400),VINT(400)
5294       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5295       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5296       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5297 C...Local arrays.
5298       DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5299      &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5300      &CEFFD(10,9),SIGTMP(6,0:5)
5301
5302 C...Common constants.
5303       DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5304      &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5305      &FACDD/0.0084D0/
5306
5307 C...Number of multiple processes to be evaluated (= 0 : undefined).
5308       DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5309 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5310       DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5311      &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5312      &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5313       DATA YPAR/
5314      &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5315      &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5316      &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5317
5318 C...Beam and target hadron class:
5319 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5320       DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5321       DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5322 C...Characteristic class masses, slope parameters, beta = sqrt(X).
5323       DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5324       DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5325       DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5326
5327 C...Fitting constants used in parametrizations of diffractive results.
5328       DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5329       DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5330       DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5331      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5332      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5333      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5334      &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5335      &0.267D0, 0.0D0, -0.46D0,  75D0, 0.267D0, 0.0D0, -0.46D0,  75D0,
5336      &0.232D0, 0.0D0, -0.46D0,  85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5337      &0.115D0, 0.0D0, -0.50D0,  90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5338      &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5339      &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5340      &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5341       DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5342      &3.11D0, -7.34D0,  9.71D0, 0.068D0, -0.42D0,  1.31D0,
5343      &-1.37D0,  35.0D0,  118D0,  3.11D0, -7.10D0,  10.6D0,
5344      &0.073D0, -0.41D0, 1.17D0, -1.41D0,  31.6D0,   95D0,
5345      &3.12D0, -7.43D0,  9.21D0, 0.067D0, -0.44D0,  1.41D0,
5346      &-1.35D0,  36.5D0,  132D0,  3.13D0, -8.18D0, -4.20D0,
5347      &0.056D0, -0.71D0, 3.12D0, -1.12D0,  55.2D0, 1298D0,
5348      &3.11D0, -6.90D0,  11.4D0, 0.078D0, -0.40D0,  1.05D0,
5349      &-1.40D0,  28.4D0,   78D0,  3.11D0, -7.13D0,  10.0D0,
5350      &0.071D0, -0.41D0, 1.23D0, -1.34D0,  33.1D0,  105D0,
5351      &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0,  2.72D0,
5352      &-1.13D0,  53.1D0,  995D0,  3.11D0, -7.39D0,  8.22D0,
5353      &0.065D0, -0.44D0, 1.45D0, -1.36D0,  38.1D0,  148D0,
5354      &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0,  3.32D0,
5355      &-1.12D0,  55.6D0, 1472D0,  4.18D0, -29.2D0,  56.2D0,
5356      &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5357
5358 C...Parameters. Combinations of the energy.
5359       AEM=PARU(101)
5360       PMTH=PARP(102)
5361       S=VINT(2)
5362       SRT=VINT(1)
5363       SEPS=S**EPS
5364       SETA=S**ETA
5365       SLOG=LOG(S)
5366
5367 C...Ratio of gamma/pi (for rescaling in parton distributions).
5368       VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5369      &(XPAR(5)*SEPS+YPAR(5)*SETA)
5370       VINT(317)=1D0
5371       IF(MINT(50).NE.1) RETURN
5372
5373 C...Order flavours of incoming particles: KF1 < KF2.
5374       IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5375         KF1=IABS(MINT(11))
5376         KF2=IABS(MINT(12))
5377         IORD=1
5378       ELSE
5379         KF1=IABS(MINT(12))
5380         KF2=IABS(MINT(11))
5381         IORD=2
5382       ENDIF
5383       ISGN12=ISIGN(1,MINT(11)*MINT(12))
5384
5385 C...Find process number (for lookup tables).
5386       IF(KF1.GT.1000) THEN
5387         IPROC=1
5388         IF(ISGN12.LT.0) IPROC=2
5389       ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5390         IPROC=3
5391         IF(ISGN12.LT.0) IPROC=4
5392         IF(KF1.EQ.111) IPROC=5
5393       ELSEIF(KF1.GT.100) THEN
5394         IPROC=11
5395       ELSEIF(KF2.GT.1000) THEN
5396         IPROC=21
5397         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5398       ELSEIF(KF2.GT.100) THEN
5399         IPROC=23
5400         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5401       ELSE
5402         IPROC=25
5403         IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5404       ENDIF
5405
5406 C... Number of multiple processes to be stored; beam/target side.
5407       NPR=NPROC(IPROC)
5408       MINT(101)=1
5409       MINT(102)=1
5410       IF(NPR.EQ.3) THEN
5411         MINT(100+IORD)=4
5412       ELSEIF(NPR.EQ.6) THEN
5413         MINT(101)=4
5414         MINT(102)=4
5415       ENDIF
5416       N1=0
5417       IF(MINT(101).EQ.4) N1=4
5418       N2=0
5419       IF(MINT(102).EQ.4) N2=4
5420
5421 C...Do not do any more for user-set or undefined cross-sections.
5422       IF(MSTP(31).LE.0) RETURN
5423       IF(NPR.EQ.0) CALL PYERRM(26,
5424      &'(PYXTOT:) cross section for this process not yet implemented')
5425
5426 C...Parameters. Combinations of the energy.
5427       AEM=PARU(101)
5428       PMTH=PARP(102)
5429       S=VINT(2)
5430       SRT=VINT(1)
5431       SEPS=S**EPS
5432       SETA=S**ETA
5433       SLOG=LOG(S)
5434
5435 C...Loop over multiple processes (for VDM).
5436       DO 110 I=1,NPR
5437         IF(NPR.EQ.1) THEN
5438           IPR=IPROC
5439         ELSEIF(NPR.EQ.3) THEN
5440           IPR=I+4
5441           IF(KF2.LT.1000) IPR=I+10
5442         ELSEIF(NPR.EQ.6) THEN
5443           IPR=I+10
5444         ENDIF
5445
5446 C...Evaluate hadron species, mass, slope contribution and fit number.
5447         IHA=IHADA(IPR)
5448         IHB=IHADB(IPR)
5449         PMA=PMHAD(IHA)
5450         PMB=PMHAD(IHB)
5451         BHA=BHAD(IHA)
5452         BHB=BHAD(IHB)
5453         ISD=IFITSD(IPR)
5454         IDD=IFITDD(IPR)
5455
5456 C...Skip if energy too low relative to masses.
5457         DO 100 J=0,5
5458           SIGTMP(I,J)=0D0
5459   100   CONTINUE
5460         IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5461
5462 C...Total cross-section. Elastic slope parameter and cross-section.
5463         SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5464         BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5465         SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5466
5467 C...Diffractive scattering A + B -> X + B.
5468         BSD=2D0*BHB
5469         SQML=(PMA+PMTH)**2
5470         SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5471         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5472      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5473         BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5474         SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5475      &  (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5476         SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5477
5478 C...Diffractive scattering A + B -> A + X.
5479         BSD=2D0*BHA
5480         SQML=(PMB+PMTH)**2
5481         SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5482         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5483      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5484         BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5485         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5486      &  (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5487         SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5488
5489 C...Order single diffractive correctly.
5490         IF(IORD.EQ.2) THEN
5491           SIGSAV=SIGTMP(I,2)
5492           SIGTMP(I,2)=SIGTMP(I,3)
5493           SIGTMP(I,3)=SIGSAV
5494         ENDIF
5495
5496 C...Double diffractive scattering A + B -> X1 + X2.
5497         YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5498         DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5499         SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5500         IF(YEFF.LE.0) SUM1=0D0
5501         SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5502         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5503         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5504         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5505      &  (2D0*ALP)
5506         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5507         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5508         SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5509      &  (2D0*ALP)
5510         BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5511         SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5512         SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5513      &  LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5514         SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5515
5516 C...Non-diffractive by unitarity.
5517         SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5518      &  SIGTMP(I,4)
5519   110 CONTINUE
5520
5521 C...Put temporary results in output array: only one process.
5522       IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5523         DO 120 J=0,5
5524           SIGT(0,0,J)=SIGTMP(1,J)
5525   120   CONTINUE
5526
5527 C...Beam multiple processes.
5528       ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5529         IF(MINT(107).EQ.2) THEN
5530           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5531         ELSE
5532           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5533      &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5534         ENDIF
5535         IF(MSTP(20).GT.0) THEN
5536           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5537         ENDIF
5538         DO 140 I=1,4
5539           IF(MINT(107).EQ.2) THEN
5540             CONV=(AEM/PARP(160+I))*VINT(317)
5541           ELSEIF(VINT(154).GT.PARP(15)) THEN
5542             CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5543      &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5544           ELSE
5545             CONV=0D0
5546           ENDIF
5547           I1=MAX(1,I-1)
5548           DO 130 J=0,5
5549             SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5550   130     CONTINUE
5551   140   CONTINUE
5552         DO 150 J=0,5
5553           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5554   150   CONTINUE
5555
5556 C...Target multiple processes.
5557       ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5558         IF(MINT(108).EQ.2) THEN
5559           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5560         ELSE
5561           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5562      &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5563         ENDIF
5564         IF(MSTP(20).GT.0) THEN
5565           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5566         ENDIF
5567         DO 170 I=1,4
5568           IF(MINT(108).EQ.2) THEN
5569             CONV=(AEM/PARP(160+I))*VINT(317)
5570           ELSEIF(VINT(154).GT.PARP(15)) THEN
5571             CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5572      &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5573           ELSE
5574             CONV=0D0
5575           ENDIF
5576           IV=MAX(1,I-1)
5577           DO 160 J=0,5
5578             SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5579   160     CONTINUE
5580   170   CONTINUE
5581         DO 180 J=0,5
5582           SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5583   180   CONTINUE
5584
5585 C...Both beam and target multiple processes.
5586       ELSE
5587         IF(MINT(107).EQ.2) THEN
5588           VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5589         ELSE
5590           VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5591      &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5592         ENDIF
5593         IF(MINT(108).EQ.2) THEN
5594           VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5595         ELSE
5596           VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5597      &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5598         ENDIF
5599         IF(MSTP(20).GT.0) THEN
5600           VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5601      &    VINT(308)))**MSTP(20)
5602         ENDIF
5603         DO 210 I1=1,4
5604           DO 200 I2=1,4
5605             IF(MINT(107).EQ.2) THEN
5606               CONV=(AEM/PARP(160+I1))*VINT(317)
5607             ELSEIF(VINT(154).GT.PARP(15)) THEN
5608               CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5609      &        (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5610             ELSE
5611               CONV=0D0
5612             ENDIF
5613             IF(MINT(108).EQ.2) THEN
5614               CONV=CONV*(AEM/PARP(160+I2))
5615             ELSEIF(VINT(154).GT.PARP(15)) THEN
5616               CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5617      &        (1D0/PARP(15)**2-1D0/VINT(154)**2)
5618             ELSE
5619               CONV=0D0
5620             ENDIF
5621             IF(I1.LE.2) THEN
5622               IV=MAX(1,I2-1)
5623             ELSEIF(I2.LE.2) THEN
5624               IV=MAX(1,I1-1)
5625             ELSEIF(I1.EQ.I2) THEN
5626               IV=2*I1-2
5627             ELSE
5628               IV=5
5629             ENDIF
5630             DO 190 J=0,5
5631               JV=J
5632               IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5633               SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5634   190       CONTINUE
5635   200     CONTINUE
5636   210   CONTINUE
5637         DO 230 J=0,5
5638           DO 220 I=1,4
5639             SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5640             SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5641   220     CONTINUE
5642           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5643   230   CONTINUE
5644       ENDIF
5645
5646 C...Scale up uniformly for Donnachie-Landshoff parametrization.
5647       IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5648         RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5649         DO 260 I1=0,N1
5650           DO 250 I2=0,N2
5651             DO 240 J=0,5
5652               SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5653   240       CONTINUE
5654   250     CONTINUE
5655   260   CONTINUE
5656       ENDIF
5657
5658       RETURN
5659       END
5660
5661 C*********************************************************************
5662
5663 C...PYMAXI
5664 C...Finds optimal set of coefficients for kinematical variable selection
5665 C...and the maximum of the part of the differential cross-section used
5666 C...in the event weighting.
5667
5668       SUBROUTINE PYMAXI
5669
5670 C...Double precision and integer declarations.
5671       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5672       IMPLICIT INTEGER(I-N)
5673       INTEGER PYK,PYCHGE,PYCOMP
5674 C...Parameter statement to help give large particle numbers.
5675       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5676      &KEXCIT=4000000,KDIMEN=5000000)
5677
5678 C...User process initialization commonblock.
5679       INTEGER MAXPUP
5680       PARAMETER (MAXPUP=100)
5681       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5682       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5683       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5684      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5685      &LPRUP(MAXPUP)
5686       SAVE /HEPRUP/
5687
5688 C...Commonblocks.
5689       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5690       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5691       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5692       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5693       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5694       COMMON/PYINT1/MINT(400),VINT(400)
5695       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5696       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5697       COMMON/PYINT4/MWID(500),WIDS(500,5)
5698       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5699       COMMON/PYINT6/PROC(0:500)
5700       CHARACTER PROC*28
5701       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5702       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5703      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5704 C...Local arrays, character variables and data.
5705       CHARACTER CVAR(4)*4
5706       DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5707      &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5708      &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5709       DATA CVAR/'tau ','tau''','y*  ','cth '/
5710       DATA SIGSSM/3*0D0/
5711
5712 C...Initial values and loop over subprocesses.
5713       NPOSI=0
5714       VINT(143)=1D0
5715       VINT(144)=1D0
5716       XSEC(0,1)=0D0
5717       DO 460 ISUB=1,500
5718         MINT(1)=ISUB
5719         MINT(51)=0
5720
5721 C...Find maximum weight factors for photon flux.
5722         IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5723           IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5724         ENDIF
5725
5726 C...Select subprocess to study: skip cases not applicable.
5727         IF(ISET(ISUB).EQ.11) THEN
5728           IF(MSUB(ISUB).NE.1) GOTO 460
5729 C...User process intialization: cross section model dependent.
5730           IF(IABS(IDWTUP).EQ.1) THEN
5731             IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5732      &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5733             XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5734           ELSE
5735             IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5736      &      XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5737      &      PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5738             IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5739      &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5740             XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5741           ENDIF
5742           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5743      &    WTGAGA*XSEC(ISUB,1)
5744           NPOSI=NPOSI+1
5745           GOTO 450
5746         ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5747           CALL PYSIGH(NCHN,SIGS)
5748           XSEC(ISUB,1)=SIGS
5749           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5750      &    WTGAGA*XSEC(ISUB,1)
5751           IF(MSUB(ISUB).NE.1) GOTO 460
5752           NPOSI=NPOSI+1
5753           GOTO 450
5754         ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5755           CALL PYSIGH(NCHN,SIGS)
5756           XSEC(ISUB,1)=SIGS
5757           IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5758      &    WTGAGA*XSEC(ISUB,1)
5759           IF(XSEC(ISUB,1).EQ.0D0) THEN
5760             MSUB(ISUB)=0
5761           ELSE
5762             NPOSI=NPOSI+1
5763           ENDIF
5764           GOTO 450
5765         ELSEIF(ISUB.EQ.96) THEN
5766           IF(MINT(50).EQ.0) GOTO 460
5767           IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5768      &    GOTO 460
5769           IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5770         ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5771      &    ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5772           IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5773         ELSE
5774           IF(MSUB(ISUB).NE.1) GOTO 460
5775         ENDIF
5776         ISTSB=ISET(ISUB)
5777         IF(ISUB.EQ.96) ISTSB=2
5778         IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5779         MWTXS=0
5780         IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5781      &  MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5782
5783 C...Find resonances (explicit or implicit in cross-section).
5784         MINT(72)=0
5785         KFR1=0
5786         IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5787           KFR1=KFPR(ISUB,1)
5788         ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5789      &    .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5790           KFR1=23
5791         ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5792      &    .OR.ISUB.EQ.177) THEN
5793           KFR1=24
5794         ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5795           KFR1=25
5796           IF(MSTP(46).EQ.5) THEN
5797             KFR1=89
5798             PMAS(89,1)=PARP(45)
5799             PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5800           ENDIF
5801         ELSEIF(ISUB.EQ.194) THEN
5802           KFR1=KTECHN+113
5803         ELSEIF(ISUB.EQ.195) THEN
5804           KFR1=KTECHN+213
5805         ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5806           KFR1=KTECHN+113
5807         ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5808           KFR1=KTECHN+213
5809         ENDIF
5810         CKMX=CKIN(2)
5811         IF(CKMX.LE.0D0) CKMX=VINT(1)
5812         KCR1=PYCOMP(KFR1)
5813         IF(KFR1.NE.0) THEN
5814           IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5815      &    CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5816         ENDIF
5817         IF(KFR1.NE.0) THEN
5818           TAUR1=PMAS(KCR1,1)**2/VINT(2)
5819           IF(KFR1.EQ.KTECHN+113) THEN
5820             CALL PYTECM(S1,S2)
5821             TAUR1=S1/VINT(2)
5822           ENDIF
5823           GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5824           MINT(72)=1
5825           MINT(73)=KFR1
5826           VINT(73)=TAUR1
5827           VINT(74)=GAMR1
5828         ENDIF
5829         KFR2=0
5830         IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5831      $  THEN
5832           KFR2=23
5833           IF(ISUB.EQ.194) THEN
5834             KFR2=KTECHN+223
5835           ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5836             KFR2=KTECHN+223
5837           ENDIF
5838           KCR2=PYCOMP(KFR2)
5839           TAUR2=PMAS(KCR2,1)**2/VINT(2)
5840           IF(KFR2.EQ.KTECHN+223) THEN
5841             CALL PYTECM(S1,S2)
5842             TAUR2=S2/VINT(2)
5843           ENDIF
5844           GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5845           IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5846      &    CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5847           IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5848             MINT(72)=2
5849             MINT(74)=KFR2
5850             VINT(75)=TAUR2
5851             VINT(76)=GAMR2
5852           ELSEIF(KFR2.NE.0) THEN
5853             KFR1=KFR2
5854             TAUR1=TAUR2
5855             GAMR1=GAMR2
5856             MINT(72)=1
5857             MINT(73)=KFR1
5858             VINT(73)=TAUR1
5859             VINT(74)=GAMR1
5860             KFR2=0
5861           ENDIF
5862         ENDIF
5863
5864 C...Find product masses and minimum pT of process.
5865         SQM3=0D0
5866         SQM4=0D0
5867         MINT(71)=0
5868         VINT(71)=CKIN(3)
5869         VINT(80)=1D0
5870         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5871           NBW=0
5872           DO 110 I=1,2
5873             PMMN(I)=0D0
5874             IF(KFPR(ISUB,I).EQ.0) THEN
5875             ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5876      &        PARP(41)) THEN
5877               IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5878               IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5879             ELSE
5880               NBW=NBW+1
5881 C...This prevents SUSY/t particles from becoming too light.
5882               KFLW=KFPR(ISUB,I)
5883               IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5884                 KCW=PYCOMP(KFLW)
5885                 PMMN(I)=PMAS(KCW,1)
5886                 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5887                   IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5888                     PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5889      &              PMAS(PYCOMP(KFDP(IDC,2)),1)
5890                     IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5891      &              PMAS(PYCOMP(KFDP(IDC,3)),1)
5892                     PMMN(I)=MIN(PMMN(I),PMSUM)
5893                   ENDIF
5894   100           CONTINUE
5895               ELSEIF(KFLW.EQ.6) THEN
5896                 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5897               ENDIF
5898             ENDIF
5899   110     CONTINUE
5900           IF(NBW.GE.1) THEN
5901             CKIN41=CKIN(41)
5902             CKIN43=CKIN(43)
5903             CKIN(41)=MAX(PMMN(1),CKIN(41))
5904             CKIN(43)=MAX(PMMN(2),CKIN(43))
5905             CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5906             CKIN(41)=CKIN41
5907             CKIN(43)=CKIN43
5908             IF(MINT(51).EQ.1) THEN
5909               WRITE(MSTU(11),5100) ISUB
5910               MSUB(ISUB)=0
5911               GOTO 460
5912             ENDIF
5913             SQM3=PQM3**2
5914             SQM4=PQM4**2
5915           ENDIF
5916           IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
5917           IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5918           IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
5919             VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5920           ELSEIF(ISUB.EQ.96) THEN
5921             VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5922           ENDIF
5923         ENDIF
5924         VINT(63)=SQM3
5925         VINT(64)=SQM4
5926
5927 C...Prepare for additional variable choices in 2 -> 3.
5928         IF(ISTSB.EQ.5) THEN
5929           VINT(201)=0D0
5930           IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5931           VINT(206)=VINT(201)
5932           VINT(204)=PMAS(23,1)
5933           IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
5934           IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
5935           IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
5936      &    .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5937           VINT(209)=VINT(204)
5938         ENDIF
5939
5940 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5941         NPTS(1)=2+2*MINT(72)
5942         IF(MINT(47).EQ.1) THEN
5943           IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
5944         ELSEIF(MINT(47).GE.5) THEN
5945           IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
5946         ENDIF
5947         NPTS(2)=1
5948         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5949           IF(MINT(47).GE.2) NPTS(2)=2
5950           IF(MINT(47).GE.5) NPTS(2)=3
5951         ENDIF
5952         NPTS(3)=1
5953         IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
5954           NPTS(3)=3
5955           IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
5956           IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
5957         ENDIF
5958         NPTS(4)=1
5959         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
5960         NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
5961
5962 C...Reset coefficients of cross-section weighting.
5963         DO 120 J=1,20
5964           COEF(ISUB,J)=0D0
5965   120   CONTINUE
5966         COEF(ISUB,1)=1D0
5967         COEF(ISUB,8)=0.5D0
5968         COEF(ISUB,9)=0.5D0
5969         COEF(ISUB,13)=1D0
5970         COEF(ISUB,18)=1D0
5971         MCTH=0
5972         MTAUP=0
5973         METAUP=0
5974         VINT(23)=0D0
5975         VINT(26)=0D0
5976         SIGSAM=0D0
5977
5978 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5979 C...in grid of phase space points.
5980         CALL PYKLIM(1)
5981         METAU=MINT(51)
5982         NACC=0
5983         DO 150 ITRY=1,NTRY
5984           MINT(51)=0
5985           IF(METAU.EQ.1) GOTO 150
5986           IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
5987             MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
5988             IF(MTAU.GT.2+2*MINT(72)) MTAU=7
5989             RTAU=0.5D0
5990 C...Special case when both resonances have same mass,
5991 C...as is often the case in process 194.
5992             IF(MINT(72).EQ.2) THEN
5993               IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
5994      &        0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
5995                 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
5996                   RTAU=0.4D0
5997                 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
5998                   RTAU=0.6D0
5999                 ENDIF
6000               ENDIF
6001             ENDIF
6002             CALL PYKMAP(1,MTAU,RTAU)
6003             IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6004             METAUP=MINT(51)
6005           ENDIF
6006           IF(METAUP.EQ.1) GOTO 150
6007           IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6008      &    .EQ.0) THEN
6009             MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6010             CALL PYKMAP(4,MTAUP,0.5D0)
6011           ENDIF
6012           IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6013             CALL PYKLIM(2)
6014             MEYST=MINT(51)
6015           ENDIF
6016           IF(MEYST.EQ.1) GOTO 150
6017           IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6018             MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6019             IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6020             CALL PYKMAP(2,MYST,0.5D0)
6021             CALL PYKLIM(3)
6022             MECTH=MINT(51)
6023           ENDIF
6024           IF(MECTH.EQ.1) GOTO 150
6025           IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6026             MCTH=1+MOD(ITRY-1,NPTS(4))
6027             CALL PYKMAP(3,MCTH,0.5D0)
6028           ENDIF
6029           IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6030
6031 C...Store position and limits.
6032           MINT(51)=0
6033           CALL PYKLIM(0)
6034           IF(MINT(51).EQ.1) GOTO 150
6035           NACC=NACC+1
6036           MVARPT(NACC,1)=MTAU
6037           MVARPT(NACC,2)=MTAUP
6038           MVARPT(NACC,3)=MYST
6039           MVARPT(NACC,4)=MCTH
6040           DO 130 J=1,30
6041             VINTPT(NACC,J)=VINT(10+J)
6042   130     CONTINUE
6043
6044 C...Normal case: calculate cross-section.
6045           IF(ISTSB.NE.5) THEN
6046             CALL PYSIGH(NCHN,SIGS)
6047             IF(MWTXS.EQ.1) THEN
6048               CALL PYEVWT(WTXS)
6049               SIGS=WTXS*SIGS
6050             ENDIF
6051
6052 C..2 -> 3: find highest value out of a number of tries.
6053           ELSE
6054             SIGS=0D0
6055             DO 140 IKIN3=1,MSTP(129)
6056               CALL PYKMAP(5,0,0D0)
6057               IF(MINT(51).EQ.1) GOTO 140
6058               CALL PYSIGH(NCHN,SIGTMP)
6059               IF(MWTXS.EQ.1) THEN
6060                 CALL PYEVWT(WTXS)
6061                 SIGTMP=WTXS*SIGTMP
6062               ENDIF
6063               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6064   140       CONTINUE
6065           ENDIF
6066
6067 C...Store cross-section.
6068           SIGSPT(NACC)=SIGS
6069           IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6070           IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6071      &    VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6072   150   CONTINUE
6073         IF(NACC.EQ.0) THEN
6074           WRITE(MSTU(11),5100) ISUB
6075           MSUB(ISUB)=0
6076           GOTO 460
6077         ELSEIF(SIGSAM.EQ.0D0) THEN
6078           WRITE(MSTU(11),5300) ISUB
6079           MSUB(ISUB)=0
6080           GOTO 460
6081         ENDIF
6082         IF(ISUB.NE.96) NPOSI=NPOSI+1
6083
6084 C...Calculate integrals in tau over maximal phase space limits.
6085         TAUMIN=VINT(11)
6086         TAUMAX=VINT(31)
6087         ATAU1=LOG(TAUMAX/TAUMIN)
6088         IF(NPTS(1).GE.2) THEN
6089           ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6090         ENDIF
6091         IF(NPTS(1).GE.4) THEN
6092           ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6093           ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6094      &    GAMR1
6095         ENDIF
6096         IF(NPTS(1).GE.6) THEN
6097           ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6098           ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6099      &    GAMR2
6100         ENDIF
6101         IF(NPTS(1).GT.2+2*MINT(72)) THEN
6102           ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6103         ENDIF
6104
6105 C...Reset. Sum up cross-sections in points calculated.
6106         DO 320 IVAR=1,4
6107           IF(NPTS(IVAR).EQ.1) GOTO 320
6108           IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6109           NBIN=NPTS(IVAR)
6110           DO 170 J1=1,NBIN
6111             NAREL(J1)=0
6112             WTREL(J1)=0D0
6113             COEFU(J1)=0D0
6114             DO 160 J2=1,NBIN
6115               WTMAT(J1,J2)=0D0
6116   160       CONTINUE
6117   170     CONTINUE
6118           DO 180 IACC=1,NACC
6119             IBIN=MVARPT(IACC,IVAR)
6120             IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6121             IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6122             NAREL(IBIN)=NAREL(IBIN)+1
6123             WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6124
6125 C...Sum up tau cross-section pieces in points used.
6126             IF(IVAR.EQ.1) THEN
6127               TAU=VINTPT(IACC,11)
6128               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6129               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6130               IF(NBIN.GE.4) THEN
6131                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6132                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6133      &          ((TAU-TAUR1)**2+GAMR1**2)
6134               ENDIF
6135               IF(NBIN.GE.6) THEN
6136                 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6137                 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6138      &          ((TAU-TAUR2)**2+GAMR2**2)
6139               ENDIF
6140               IF(NBIN.GT.2+2*MINT(72)) THEN
6141                 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6142      &          TAU/MAX(2D-10,1D0-TAU)
6143               ENDIF
6144
6145 C...Sum up tau' cross-section pieces in points used.
6146             ELSEIF(IVAR.EQ.2) THEN
6147               TAU=VINTPT(IACC,11)
6148               TAUP=VINTPT(IACC,16)
6149               TAUPMN=VINTPT(IACC,6)
6150               TAUPMX=VINTPT(IACC,26)
6151               ATAUP1=LOG(TAUPMX/TAUPMN)
6152               ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6153               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6154               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6155      &        (1D0-TAU/TAUP)**3/TAUP
6156               IF(NBIN.GE.3) THEN
6157                 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6158                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6159      &          TAUP/MAX(2D-10,1D0-TAUP)
6160               ENDIF
6161
6162 C...Sum up y* cross-section pieces in points used.
6163             ELSEIF(IVAR.EQ.3) THEN
6164               YST=VINTPT(IACC,12)
6165               YSTMIN=VINTPT(IACC,2)
6166               YSTMAX=VINTPT(IACC,22)
6167               AYST0=YSTMAX-YSTMIN
6168               AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6169               AYST2=AYST1
6170               AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6171               WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6172               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6173               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6174               IF(MINT(45).EQ.3) THEN
6175                 TAUE=VINTPT(IACC,11)
6176                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6177                 YST0=-0.5D0*LOG(TAUE)
6178                 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6179      &          MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6180                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6181      &          MAX(1D-10,1D0-EXP(YST-YST0))
6182               ENDIF
6183               IF(MINT(46).EQ.3) THEN
6184                 TAUE=VINTPT(IACC,11)
6185                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6186                 YST0=-0.5D0*LOG(TAUE)
6187                 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6188      &          MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6189                 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6190      &          MAX(1D-10,1D0-EXP(-YST-YST0))
6191               ENDIF
6192
6193 C...Sum up cos(theta-hat) cross-section pieces in points used.
6194             ELSE
6195               RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6196               RSQM=1D0+RM34
6197               CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6198               CTHMIN=-CTHMAX
6199               IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6200      &        (TAUMAX*VINT(2)))
6201               ACTH1=CTHMAX-CTHMIN
6202               ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6203               ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6204               ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6205               ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6206               CTH=VINTPT(IACC,13)
6207               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6208               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6209      &        MAX(RM34,RSQM-CTH)
6210               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6211      &        MAX(RM34,RSQM+CTH)
6212               WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6213      &        MAX(RM34,RSQM-CTH)**2
6214               WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6215      &        MAX(RM34,RSQM+CTH)**2
6216             ENDIF
6217   180     CONTINUE
6218
6219 C...Check that equation system solvable.
6220           IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6221           MSOLV=1
6222           WTRELS=0D0
6223           DO 190 IBIN=1,NBIN
6224             IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6225      &      IRED=1,NBIN),WTREL(IBIN)
6226             IF(NAREL(IBIN).EQ.0) MSOLV=0
6227             WTRELS=WTRELS+WTREL(IBIN)
6228   190     CONTINUE
6229           IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6230
6231 C...Solve to find relative importance of cross-section pieces.
6232           IF(MSOLV.EQ.1) THEN
6233             DO 200 IBIN=1,NBIN
6234               WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6235   200       CONTINUE
6236             DO 230 IRED=1,NBIN-1
6237               DO 220 IBIN=IRED+1,NBIN
6238                 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6239                   MSOLV=0
6240                   GOTO 260
6241                 ENDIF
6242                 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6243                 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6244                 DO 210 ICOE=IRED,NBIN
6245                   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6246   210           CONTINUE
6247   220         CONTINUE
6248   230       CONTINUE
6249             DO 250 IRED=NBIN,1,-1
6250               DO 240 ICOE=IRED+1,NBIN
6251                 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6252   240         CONTINUE
6253               COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6254   250       CONTINUE
6255           ENDIF
6256
6257 C...Share evenly if failure.
6258   260     IF(MSOLV.EQ.0) THEN
6259             DO 270 IBIN=1,NBIN
6260               COEFU(IBIN)=1D0
6261               WTRELN(IBIN)=0.1D0
6262               IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6263      &        WTREL(IBIN)/WTRELS)
6264   270       CONTINUE
6265           ENDIF
6266
6267 C...Normalize coefficients, with piece shared democratically.
6268           COEFSU=0D0
6269           WTRELS=0D0
6270           DO 280 IBIN=1,NBIN
6271             COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6272             COEFSU=COEFSU+COEFU(IBIN)
6273             WTRELS=WTRELS+WTRELN(IBIN)
6274   280     CONTINUE
6275           IF(COEFSU.GT.0D0) THEN
6276             DO 290 IBIN=1,NBIN
6277               COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6278      &        (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6279   290       CONTINUE
6280           ELSE
6281             DO 300 IBIN=1,NBIN
6282               COEFO(IBIN)=1D0/NBIN
6283   300       CONTINUE
6284           ENDIF
6285           IF(IVAR.EQ.1) IOFF=0
6286           IF(IVAR.EQ.2) IOFF=17
6287           IF(IVAR.EQ.3) IOFF=7
6288           IF(IVAR.EQ.4) IOFF=12
6289           DO 310 IBIN=1,NBIN
6290             ICOF=IOFF+IBIN
6291             IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6292             IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6293             COEF(ISUB,ICOF)=COEFO(IBIN)
6294   310     CONTINUE
6295           IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6296      &    (COEFO(IBIN),IBIN=1,NBIN)
6297   320   CONTINUE
6298
6299 C...Find two most promising maxima among points previously determined.
6300         DO 330 J=1,4
6301           IACCMX(J)=0
6302           SIGSMX(J)=0D0
6303   330   CONTINUE
6304         NMAX=0
6305         DO 390 IACC=1,NACC
6306           DO 340 J=1,30
6307             VINT(10+J)=VINTPT(IACC,J)
6308   340     CONTINUE
6309           IF(ISTSB.NE.5) THEN
6310             CALL PYSIGH(NCHN,SIGS)
6311             IF(MWTXS.EQ.1) THEN
6312               CALL PYEVWT(WTXS)
6313               SIGS=WTXS*SIGS
6314             ENDIF
6315           ELSE
6316             SIGS=0D0
6317             DO 350 IKIN3=1,MSTP(129)
6318               CALL PYKMAP(5,0,0D0)
6319               IF(MINT(51).EQ.1) GOTO 350
6320               CALL PYSIGH(NCHN,SIGTMP)
6321               IF(MWTXS.EQ.1) THEN
6322                 CALL PYEVWT(WTXS)
6323                 SIGTMP=WTXS*SIGTMP
6324               ENDIF
6325               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6326   350       CONTINUE
6327           ENDIF
6328           IEQ=0
6329           DO 360 IMV=1,NMAX
6330             IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6331   360     CONTINUE
6332           IF(IEQ.EQ.0) THEN
6333             DO 370 IMV=NMAX,1,-1
6334               IIN=IMV+1
6335               IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6336               IACCMX(IMV+1)=IACCMX(IMV)
6337               SIGSMX(IMV+1)=SIGSMX(IMV)
6338   370       CONTINUE
6339             IIN=1
6340   380       IACCMX(IIN)=IACC
6341             SIGSMX(IIN)=SIGS
6342             IF(NMAX.LE.1) NMAX=NMAX+1
6343           ENDIF
6344   390   CONTINUE
6345
6346 C...Read out starting position for search.
6347         IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6348         SIGSAM=SIGSMX(1)
6349         DO 440 IMAX=1,NMAX
6350           IACC=IACCMX(IMAX)
6351           MTAU=MVARPT(IACC,1)
6352           MTAUP=MVARPT(IACC,2)
6353           MYST=MVARPT(IACC,3)
6354           MCTH=MVARPT(IACC,4)
6355           VTAU=0.5D0
6356           VYST=0.5D0
6357           VCTH=0.5D0
6358           VTAUP=0.5D0
6359
6360 C...Starting point and step size in parameter space.
6361           DO 430 IRPT=1,2
6362             DO 420 IVAR=1,4
6363               IF(NPTS(IVAR).EQ.1) GOTO 420
6364               IF(IVAR.EQ.1) VVAR=VTAU
6365               IF(IVAR.EQ.2) VVAR=VTAUP
6366               IF(IVAR.EQ.3) VVAR=VYST
6367               IF(IVAR.EQ.4) VVAR=VCTH
6368               IF(IVAR.EQ.1) MVAR=MTAU
6369               IF(IVAR.EQ.2) MVAR=MTAUP
6370               IF(IVAR.EQ.3) MVAR=MYST
6371               IF(IVAR.EQ.4) MVAR=MCTH
6372               IF(IRPT.EQ.1) VDEL=0.1D0
6373               IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6374      &        0.98D0-VVAR))
6375               IF(IRPT.EQ.1) VMAR=0.02D0
6376               IF(IRPT.EQ.2) VMAR=0.002D0
6377               IMOV0=1
6378               IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6379               DO 410 IMOV=IMOV0,8
6380
6381 C...Define new point in parameter space.
6382                 IF(IMOV.EQ.0) THEN
6383                   INEW=2
6384                   VNEW=VVAR
6385                 ELSEIF(IMOV.EQ.1) THEN
6386                   INEW=3
6387                   VNEW=VVAR+VDEL
6388                 ELSEIF(IMOV.EQ.2) THEN
6389                   INEW=1
6390                   VNEW=VVAR-VDEL
6391                 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6392      &            VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6393                   VVAR=VVAR+VDEL
6394                   SIGSSM(1)=SIGSSM(2)
6395                   SIGSSM(2)=SIGSSM(3)
6396                   INEW=3
6397                   VNEW=VVAR+VDEL
6398                 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6399      &            VVAR-2D0*VDEL.GT.VMAR) THEN
6400                   VVAR=VVAR-VDEL
6401                   SIGSSM(3)=SIGSSM(2)
6402                   SIGSSM(2)=SIGSSM(1)
6403                   INEW=1
6404                   VNEW=VVAR-VDEL
6405                 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6406                   VDEL=0.5D0*VDEL
6407                   VVAR=VVAR+VDEL
6408                   SIGSSM(1)=SIGSSM(2)
6409                   INEW=2
6410                   VNEW=VVAR
6411                 ELSE
6412                   VDEL=0.5D0*VDEL
6413                   VVAR=VVAR-VDEL
6414                   SIGSSM(3)=SIGSSM(2)
6415                   INEW=2
6416                   VNEW=VVAR
6417                 ENDIF
6418
6419 C...Convert to relevant variables and find derived new limits.
6420                 ILERR=0
6421                 IF(IVAR.EQ.1) THEN
6422                   VTAU=VNEW
6423                   CALL PYKMAP(1,MTAU,VTAU)
6424                   IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6425                     CALL PYKLIM(4)
6426                     IF(MINT(51).EQ.1) ILERR=1
6427                   ENDIF
6428                 ENDIF
6429                 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6430      &          ILERR.EQ.0) THEN
6431                   IF(IVAR.EQ.2) VTAUP=VNEW
6432                   CALL PYKMAP(4,MTAUP,VTAUP)
6433                 ENDIF
6434                 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6435                   CALL PYKLIM(2)
6436                   IF(MINT(51).EQ.1) ILERR=1
6437                 ENDIF
6438                 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6439                   IF(IVAR.EQ.3) VYST=VNEW
6440                   CALL PYKMAP(2,MYST,VYST)
6441                   CALL PYKLIM(3)
6442                   IF(MINT(51).EQ.1) ILERR=1
6443                 ENDIF
6444                 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6445      &          ILERR.EQ.0) THEN
6446                   IF(IVAR.EQ.4) VCTH=VNEW
6447                   CALL PYKMAP(3,MCTH,VCTH)
6448                 ENDIF
6449                 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6450
6451 C...Evaluate cross-section. Save new maximum. Final maximum.
6452                 IF(ILERR.NE.0) THEN
6453                    SIGS=0.
6454                 ELSEIF(ISTSB.NE.5) THEN
6455                   CALL PYSIGH(NCHN,SIGS)
6456                   IF(MWTXS.EQ.1) THEN
6457                     CALL PYEVWT(WTXS)
6458                     SIGS=WTXS*SIGS
6459                   ENDIF
6460                 ELSE
6461                   SIGS=0D0
6462                   DO 400 IKIN3=1,MSTP(129)
6463                     CALL PYKMAP(5,0,0D0)
6464                     IF(MINT(51).EQ.1) GOTO 400
6465                     CALL PYSIGH(NCHN,SIGTMP)
6466                     IF(MWTXS.EQ.1) THEN
6467                         CALL PYEVWT(WTXS)
6468                         SIGTMP=WTXS*SIGTMP
6469                     ENDIF
6470                     IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6471   400             CONTINUE
6472                 ENDIF
6473                 SIGSSM(INEW)=SIGS
6474                 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6475                 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6476      &          IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6477   410         CONTINUE
6478   420       CONTINUE
6479   430     CONTINUE
6480   440   CONTINUE
6481         IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6482         XSEC(ISUB,1)=1.05D0*SIGSAM
6483         IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6484      &  WTGAGA*XSEC(ISUB,1)
6485   450   CONTINUE
6486         IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6487      &  PARP(174)*XSEC(ISUB,1)
6488         IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6489   460 CONTINUE
6490       MINT(51)=0
6491
6492 C...Print summary table.
6493       IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6494         IF(MSTP(127).NE.1) THEN
6495           WRITE(MSTU(11),5900)
6496           STOP
6497         ELSE
6498           WRITE(MSTU(11),6400)
6499           MSTI(53)=1
6500         ENDIF
6501       ENDIF
6502       IF(MSTP(122).GE.1) THEN
6503         WRITE(MSTU(11),6000)
6504         WRITE(MSTU(11),6100)
6505         DO 470 ISUB=1,500
6506           IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6507           IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6508           IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6509           IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6510           IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6511      &    .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6512           WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6513   470   CONTINUE
6514         WRITE(MSTU(11),6300)
6515       ENDIF
6516
6517 C...Format statements for maximization results.
6518  5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6519      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,
6520      &'cth',9X,'tau''',7X,'sigma')
6521  5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6522      &'phase space.'/1X,'Process switched off!')
6523  5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6524  5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6525      &'cross-section.'/1X,'Process switched off!')
6526  5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6527  5500 FORMAT(1X,1P,8D11.3)
6528  5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6529  5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6530      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6531  5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6532  5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6533      &'cross-section.'/1X,'Execution stopped!')
6534  6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6535      &'cross-section maximum search',1X,8('*'))
6536  6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',
6537      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',
6538      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6539  6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6540  6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6541  6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6542      &'cross-section.'/
6543      &1X,'Execution will stop if you try to generate events.')
6544
6545       RETURN
6546       END
6547
6548 C*********************************************************************
6549
6550 C...PYPILE
6551 C...Initializes multiplicity distribution and selects mutliplicity
6552 C...of pileup events, i.e. several events occuring at the same
6553 C...beam crossing.
6554
6555       SUBROUTINE PYPILE(MPILE)
6556
6557 C...Double precision and integer declarations.
6558       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6559       IMPLICIT INTEGER(I-N)
6560       INTEGER PYK,PYCHGE,PYCOMP
6561 C...Commonblocks.
6562       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6563       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6564       COMMON/PYINT1/MINT(400),VINT(400)
6565       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6566       SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6567 C...Local arrays and saved variables.
6568       DIMENSION WTI(0:200)
6569       SAVE IMIN,IMAX,WTI,WTS
6570
6571 C...Sum of allowed cross-sections for pileup events.
6572       IF(MPILE.EQ.1) THEN
6573         VINT(131)=SIGT(0,0,5)
6574         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6575         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6576         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6577         IF(MSTP(133).LE.0) RETURN
6578
6579 C...Initialize multiplicity distribution at maximum.
6580         XNAVE=VINT(131)*PARP(131)
6581         IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6582         INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6583         WTI(INAVE)=1D0
6584         WTS=WTI(INAVE)
6585         WTN=WTI(INAVE)*INAVE
6586
6587 C...Find shape of multiplicity distribution below maximum.
6588         IMIN=INAVE
6589         DO 100 I=INAVE-1,1,-1
6590           IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6591           IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6592           IF(WTI(I).LT.1D-6) GOTO 110
6593           WTS=WTS+WTI(I)
6594           WTN=WTN+WTI(I)*I
6595           IMIN=I
6596   100   CONTINUE
6597
6598 C...Find shape of multiplicity distribution above maximum.
6599   110   IMAX=INAVE
6600         DO 120 I=INAVE+1,200
6601           IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6602           IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6603           IF(WTI(I).LT.1D-6) GOTO 130
6604           WTS=WTS+WTI(I)
6605           WTN=WTN+WTI(I)*I
6606           IMAX=I
6607   120   CONTINUE
6608   130   VINT(132)=XNAVE
6609         VINT(133)=WTN/WTS
6610         IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6611      &  WTS/(WTS+WTI(1)/XNAVE)
6612         IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6613         IF(MSTP(133).GE.2) VINT(134)=XNAVE
6614
6615 C...Pick multiplicity of pileup events.
6616       ELSE
6617         IF(MSTP(133).LE.0) THEN
6618           MINT(81)=MAX(1,MSTP(134))
6619         ELSE
6620           WTR=WTS*PYR(0)
6621           DO 140 I=IMIN,IMAX
6622             MINT(81)=I
6623             WTR=WTR-WTI(I)
6624             IF(WTR.LE.0D0) GOTO 150
6625   140     CONTINUE
6626   150     CONTINUE
6627         ENDIF
6628       ENDIF
6629
6630 C...Format statement for error message.
6631  5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6632      &'crossing too large, ',1P,D12.4)
6633
6634       RETURN
6635       END
6636
6637 C*********************************************************************
6638
6639 C...PYSAVE
6640 C...Saves and restores parameter and cross section values for the
6641 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6642 C...Also makes random choice between alternatives.
6643
6644       SUBROUTINE PYSAVE(ISAVE,IGA)
6645
6646 C...Double precision and integer declarations.
6647       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6648       IMPLICIT INTEGER(I-N)
6649       INTEGER PYK,PYCHGE,PYCOMP
6650 C...Commonblocks.
6651       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6652       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6653       COMMON/PYINT1/MINT(400),VINT(400)
6654       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6655       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6656       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6657       SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6658 C...Local arrays and saved variables.
6659       DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6660      &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6661      &INTCP(15,20),RECP(15,20)
6662       SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6663
6664 C...Save list of subprocesses and cross-section information.
6665       IF(ISAVE.EQ.1) THEN
6666         ICP=0
6667         DO 120 I=1,500
6668           IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6669           ICP=ICP+1
6670           NSUBCP(IGA,ICP)=I
6671           MSUBCP(IGA,ICP)=MSUB(I)
6672           DO 100 J=1,20
6673             COEFCP(IGA,ICP,J)=COEF(I,J)
6674   100     CONTINUE
6675           DO 110 J=1,3
6676             NGENCP(IGA,ICP,J)=NGEN(I,J)
6677             XSECCP(IGA,ICP,J)=XSEC(I,J)
6678   110     CONTINUE
6679   120   CONTINUE
6680         NCP(IGA)=ICP
6681         DO 130 J=1,3
6682           NGENCP(IGA,0,J)=NGEN(0,J)
6683           XSECCP(IGA,0,J)=XSEC(0,J)
6684   130   CONTINUE
6685         DO 160 I1=0,6
6686           DO 150 I2=0,6
6687             DO 140 J=0,5
6688               SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6689   140       CONTINUE
6690   150     CONTINUE
6691   160   CONTINUE
6692
6693 C...Save various common process variables.
6694         DO 170 J=1,10
6695           INTCP(IGA,J)=MINT(40+J)
6696   170   CONTINUE
6697         INTCP(IGA,11)=MINT(101)
6698         INTCP(IGA,12)=MINT(102)
6699         INTCP(IGA,13)=MINT(107)
6700         INTCP(IGA,14)=MINT(108)
6701         INTCP(IGA,15)=MINT(123)
6702         RECP(IGA,1)=CKIN(3)
6703         RECP(IGA,2)=VINT(318)
6704
6705 C...Save cross-section information only.
6706       ELSEIF(ISAVE.EQ.2) THEN
6707         DO 190 ICP=1,NCP(IGA)
6708           I=NSUBCP(IGA,ICP)
6709           DO 180 J=1,3
6710             NGENCP(IGA,ICP,J)=NGEN(I,J)
6711             XSECCP(IGA,ICP,J)=XSEC(I,J)
6712   180     CONTINUE
6713   190   CONTINUE
6714         DO 200 J=1,3
6715           NGENCP(IGA,0,J)=NGEN(0,J)
6716           XSECCP(IGA,0,J)=XSEC(0,J)
6717   200   CONTINUE
6718
6719 C...Choose between allowed alternatives.
6720       ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6721         IF(ISAVE.EQ.4) THEN
6722           XSUMCP=0D0
6723           DO 210 IG=1,MINT(121)
6724             XSUMCP=XSUMCP+XSECCP(IG,0,1)
6725   210     CONTINUE
6726           XSUMCP=XSUMCP*PYR(0)
6727           DO 220 IG=1,MINT(121)
6728             IGA=IG
6729             XSUMCP=XSUMCP-XSECCP(IG,0,1)
6730             IF(XSUMCP.LE.0D0) GOTO 230
6731   220     CONTINUE
6732   230     CONTINUE
6733         ENDIF
6734
6735 C...Restore cross-section information.
6736         DO 240 I=1,500
6737           MSUB(I)=0
6738   240   CONTINUE
6739         DO 270 ICP=1,NCP(IGA)
6740           I=NSUBCP(IGA,ICP)
6741           MSUB(I)=MSUBCP(IGA,ICP)
6742           DO 250 J=1,20
6743             COEF(I,J)=COEFCP(IGA,ICP,J)
6744   250     CONTINUE
6745           DO 260 J=1,3
6746             NGEN(I,J)=NGENCP(IGA,ICP,J)
6747             XSEC(I,J)=XSECCP(IGA,ICP,J)
6748   260     CONTINUE
6749   270   CONTINUE
6750         DO 280 J=1,3
6751           NGEN(0,J)=NGENCP(IGA,0,J)
6752           XSEC(0,J)=XSECCP(IGA,0,J)
6753   280   CONTINUE
6754         DO 310 I1=0,6
6755           DO 300 I2=0,6
6756             DO 290 J=0,5
6757               SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6758   290       CONTINUE
6759   300     CONTINUE
6760   310   CONTINUE
6761
6762 C...Restore various common process variables.
6763         DO 320 J=1,10
6764           MINT(40+J)=INTCP(IGA,J)
6765   320   CONTINUE
6766         MINT(101)=INTCP(IGA,11)
6767         MINT(102)=INTCP(IGA,12)
6768         MINT(107)=INTCP(IGA,13)
6769         MINT(108)=INTCP(IGA,14)
6770         MINT(123)=INTCP(IGA,15)
6771         CKIN(3)=RECP(IGA,1)
6772         CKIN(1)=2D0*CKIN(3)
6773         VINT(318)=RECP(IGA,2)
6774
6775 C...Sum up cross-section info (for PYSTAT).
6776       ELSEIF(ISAVE.EQ.5) THEN
6777         DO 330 I=1,500
6778           MSUB(I)=0
6779           NGEN(I,1)=0
6780           NGEN(I,3)=0
6781           XSEC(I,3)=0D0
6782   330   CONTINUE
6783         NGEN(0,1)=0
6784         NGEN(0,2)=0
6785         NGEN(0,3)=0
6786         XSEC(0,3)=0
6787         DO 350 IG=1,MINT(121)
6788           DO 340 ICP=1,NCP(IG)
6789             I=NSUBCP(IG,ICP)
6790             IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6791             NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6792             NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6793             XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6794   340     CONTINUE
6795           NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6796           NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6797           NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6798           XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6799   350   CONTINUE
6800       ENDIF
6801
6802       RETURN
6803       END
6804
6805 C*********************************************************************
6806
6807 C...PYGAGA
6808 C...For lepton beams it gives photon-hadron or photon-photon systems
6809 C...to be treated with the ordinary machinery and combines this with a
6810 C...description of the lepton -> lepton + photon branching.
6811
6812       SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6813
6814 C...Double precision and integer declarations.
6815       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6816       IMPLICIT INTEGER(I-N)
6817       INTEGER PYK,PYCHGE,PYCOMP
6818 C...Commonblocks.
6819       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6820       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6821       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6822       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6823       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6824       COMMON/PYINT1/MINT(400),VINT(400)
6825       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6826       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6827      &/PYINT5/
6828 C...Local variables and data statement.
6829       DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6830      &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6831       SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6832       DATA EPS/1D-4/
6833
6834 C...Initialize generation of photons inside leptons.
6835       IF(IGAGA.EQ.1) THEN
6836
6837 C...Save quantities on incoming lepton system.
6838         VINT(301)=VINT(1)
6839         VINT(302)=VINT(2)
6840         PMS(1)=VINT(303)**2
6841         IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
6842         PMS(2)=VINT(304)**2
6843         IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
6844         PMC(3)=VINT(302)-PMS(1)-PMS(2)
6845         W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
6846
6847 C...Calculate range of x and Q2 values allowed in generation.
6848         DO 100 I=1,2
6849           PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
6850           IF(MINT(140+I).NE.0) THEN
6851             XMIN(I)=MAX(CKIN(59+2*I),EPS)
6852             XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
6853      &      PMC(I),1D0-EPS)
6854             YMIN=MAX(CKIN(71+2*I),EPS)
6855             YMAX=MIN(CKIN(72+2*I),1D0-EPS)
6856             IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
6857      &      (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
6858             XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
6859             THEMIN=MAX(CKIN(67+2*I),0D0)
6860             THEMAX=MIN(CKIN(68+2*I),PARU(1))
6861             IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
6862             Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
6863      &      ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
6864      &      2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
6865             Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
6866      &      ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
6867      &      2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
6868             IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
6869 C...W limits when lepton on one side only.
6870             IF(MINT(143-I).EQ.0) THEN
6871               XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
6872               IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
6873      &        (CKIN(78)**2-PMS(3-I))/PMC(I))
6874             ENDIF
6875           ENDIF
6876   100   CONTINUE
6877
6878 C...W limits when lepton on both sides.
6879         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6880           IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
6881      &    (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
6882           IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
6883      &    (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
6884           IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
6885             XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
6886      &      PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
6887             XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
6888      &      PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
6889           ELSE
6890             XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
6891             XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
6892           ENDIF
6893         ENDIF
6894
6895 C...Q2 and W values and photon flux weight factors for initialization.
6896       ELSEIF(IGAGA.EQ.2) THEN
6897         ISUB=MINT(1)
6898         MINT(15)=0
6899         MINT(16)=0
6900
6901 C...W value for photon on one or both sides, and for processes
6902 C...with gamma-gamma cross section peaked at small shat.
6903         IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
6904           VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
6905         ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
6906           VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
6907         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
6908           VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
6909           IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6910         ELSE
6911           VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
6912           IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6913         ENDIF
6914         VINT(1)=SQRT(MAX(0D0,VINT(2)))
6915
6916 C...Upper estimate of photon flux weight factor.
6917 C...Initialization Q2 scale. Flag incoming unresolved photon.
6918         WTGAGA=1D0
6919         DO 110 I=1,2
6920           IF(MINT(140+I).NE.0) THEN
6921             WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6922      &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6923             IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
6924      &      THEN
6925               Q2INIT=5D0+Q2MIN(3-I)
6926             ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
6927               Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
6928             ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6929               Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
6930             ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
6931      &      (ISUB.EQ.139.AND.I.EQ.1)) THEN
6932               Q2INIT=VINT(2)/3D0
6933             ELSEIF(ISUB.EQ.140) THEN
6934               Q2INIT=VINT(2)/2D0
6935             ELSE
6936               Q2INIT=Q2MIN(I)
6937             ENDIF
6938             VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
6939             IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
6940      &      MINT(14+I)=22
6941             VINT(306+I)=VINT(2+I)**2
6942           ENDIF
6943   110   CONTINUE
6944         VINT(320)=WTGAGA
6945
6946 C...Update pTmin and cross section information.
6947         IF(MSTP(82).LE.1) THEN
6948           PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6949         ELSE
6950           PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6951         ENDIF
6952         VINT(149)=4D0*PTMN**2/VINT(2)
6953         VINT(154)=PTMN
6954         CALL PYXTOT
6955         VINT(318)=VINT(317)
6956
6957 C...Generate photons inside leptons and
6958 C...calculate photon flux weight factors.
6959       ELSEIF(IGAGA.EQ.3) THEN
6960         ISUB=MINT(1)
6961         MINT(15)=0
6962         MINT(16)=0
6963
6964 C...Generate phase space point and check against cuts.
6965         LOOP=0
6966   120   LOOP=LOOP+1
6967         DO 130 I=1,2
6968           IF(MINT(140+I).NE.0) THEN
6969 C...Pick x and Q2
6970             X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
6971             Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
6972 C...Cuts on internal consistency in x and Q2.
6973             IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
6974             IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
6975      &      (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
6976 C...Cuts on y and theta.
6977             Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
6978             IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
6979             RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
6980      &      ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
6981             THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
6982             IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
6983             IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
6984      &      GOTO 120
6985
6986 C...Phi angle isotropic. Reconstruct pT.
6987             PHI(I)=PARU(2)*PYR(0)
6988             PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
6989      &      PMS(I))*SIN(THETA(I))
6990
6991 C...Store info on variables selected, for documentation purposes.
6992             VINT(2+I)=-SQRT(Q2(I))
6993             VINT(304+I)=X(I)
6994             VINT(306+I)=Q2(I)
6995             VINT(308+I)=Y(I)
6996             VINT(310+I)=THETA(I)
6997             VINT(312+I)=PHI(I)
6998           ELSE
6999             VINT(304+I)=1D0
7000             VINT(306+I)=0D0
7001             VINT(308+I)=1D0
7002             VINT(310+I)=0D0
7003             VINT(312+I)=0D0
7004           ENDIF
7005   130   CONTINUE
7006
7007 C...Cut on W combines info from two sides.
7008         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7009           W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7010      &    2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7011      &    SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7012      &    SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7013           IF(W2.LT.W2MIN) GOTO 120
7014           IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7015           PMS1=-Q2(1)
7016           PMS2=-Q2(2)
7017         ELSEIF(MINT(141).NE.0) THEN
7018           W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7019           PMS1=-Q2(1)
7020           PMS2=PMS(2)
7021         ELSEIF(MINT(142).NE.0) THEN
7022           W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7023           PMS1=PMS(1)
7024           PMS2=-Q2(2)
7025         ENDIF
7026
7027 C...Store kinematics info for photon(s) in subsystem cm frame.
7028         VINT(2)=W2
7029         VINT(1)=SQRT(W2)
7030         VINT(291)=0D0
7031         VINT(292)=0D0
7032         VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7033         VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7034         VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7035         VINT(296)=0D0
7036         VINT(297)=0D0
7037         VINT(298)=-VINT(293)
7038         VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7039         VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7040
7041 C...Assign weight for photon flux; different for transverse and
7042 C...longitudinal photons. Flag incoming unresolved photon.
7043         WTGAGA=1D0
7044         DO 140 I=1,2
7045           IF(MINT(140+I).NE.0) THEN
7046             WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7047      &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7048             IF(MSTP(16).EQ.0) THEN
7049               XY=X(I)
7050             ELSE
7051               WTGAGA=WTGAGA*X(I)/Y(I)
7052               XY=Y(I)
7053             ENDIF
7054             IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7055               WTGAGA=WTGAGA*(1D0-XY)
7056             ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7057               WTGAGA=WTGAGA*(1D0-XY)
7058             ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7059               WTGAGA=WTGAGA*(1D0-XY)
7060             ELSE
7061               WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7062      &        PMS(I)*XY**2/Q2(I))
7063             ENDIF
7064             IF(MINT(106+I).EQ.0) MINT(14+I)=22
7065           ENDIF
7066   140   CONTINUE
7067         VINT(319)=WTGAGA
7068         MINT(143)=LOOP
7069
7070 C...Update pTmin and cross section information.
7071         IF(MSTP(82).LE.1) THEN
7072           PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7073         ELSE
7074           PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7075         ENDIF
7076         VINT(149)=4D0*PTMN**2/VINT(2)
7077         VINT(154)=PTMN
7078         CALL PYXTOT
7079
7080 C...Reconstruct kinematics of photons inside leptons.
7081       ELSEIF(IGAGA.EQ.4) THEN
7082
7083 C...Make place for incoming particles and scattered leptons.
7084         MOVE=3
7085         IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7086         MINT(4)=MINT(4)+MOVE
7087         DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7088           IF(K(I,1).EQ.21) THEN
7089             DO 150 J=1,5
7090               K(I+MOVE,J)=K(I,J)
7091               P(I+MOVE,J)=P(I,J)
7092               V(I+MOVE,J)=V(I,J)
7093   150       CONTINUE
7094             IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7095      &      K(I+MOVE,3)=K(I,3)+MOVE
7096             IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7097      &      K(I+MOVE,4)=K(I,4)+MOVE
7098             IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7099      &      K(I+MOVE,5)=K(I,5)+MOVE
7100           ENDIF
7101   160   CONTINUE
7102         DO 170 I=MINT(84)+1,N
7103           IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7104      &    K(I,3)=K(I,3)+MOVE
7105   170   CONTINUE
7106
7107 C...Fill in incoming particles.
7108         DO 190 I=MINT(83)+1,MINT(83)+MOVE
7109           DO 180 J=1,5
7110             K(I,J)=0
7111             P(I,J)=0D0
7112             V(I,J)=0D0
7113   180     CONTINUE
7114   190   CONTINUE
7115         DO 200 I=1,2
7116           K(MINT(83)+I,1)=21
7117           IF(MINT(140+I).NE.0) THEN
7118             K(MINT(83)+I,2)=MINT(140+I)
7119             P(MINT(83)+I,5)=VINT(302+I)
7120           ELSE
7121             K(MINT(83)+I,2)=MINT(10+I)
7122             P(MINT(83)+I,5)=VINT(2+I)
7123           ENDIF
7124           P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7125      &    VINT(302))*(-1D0)**(I+1)
7126           P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7127   200   CONTINUE
7128
7129 C...New mother-daughter relations in documentation section.
7130         IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7131           K(MINT(83)+1,4)=MINT(83)+3
7132           K(MINT(83)+1,5)=MINT(83)+5
7133           K(MINT(83)+2,4)=MINT(83)+4
7134           K(MINT(83)+2,5)=MINT(83)+6
7135           K(MINT(83)+3,3)=MINT(83)+1
7136           K(MINT(83)+5,3)=MINT(83)+1
7137           K(MINT(83)+4,3)=MINT(83)+2
7138           K(MINT(83)+6,3)=MINT(83)+2
7139         ELSEIF(MINT(141).NE.0) THEN
7140           K(MINT(83)+1,4)=MINT(83)+3
7141           K(MINT(83)+1,5)=MINT(83)+4
7142           K(MINT(83)+2,4)=MINT(83)+5
7143           K(MINT(83)+3,3)=MINT(83)+1
7144           K(MINT(83)+4,3)=MINT(83)+1
7145           K(MINT(83)+5,3)=MINT(83)+2
7146         ELSEIF(MINT(142).NE.0) THEN
7147           K(MINT(83)+1,4)=MINT(83)+4
7148           K(MINT(83)+2,4)=MINT(83)+3
7149           K(MINT(83)+2,5)=MINT(83)+5
7150           K(MINT(83)+3,3)=MINT(83)+2
7151           K(MINT(83)+4,3)=MINT(83)+1
7152           K(MINT(83)+5,3)=MINT(83)+2
7153         ENDIF
7154
7155 C...Fill scattered lepton(s).
7156         DO 210 I=1,2
7157           IF(MINT(140+I).NE.0) THEN
7158             LSC=MINT(83)+MIN(I+2,MOVE)
7159             K(LSC,1)=21
7160             K(LSC,2)=MINT(140+I)
7161             P(LSC,1)=PT(I)*COS(PHI(I))
7162             P(LSC,2)=PT(I)*SIN(PHI(I))
7163             P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7164             P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7165      &      (-1D0)**(I-1)
7166             P(LSC,5)=VINT(302+I)
7167           ENDIF
7168   210   CONTINUE
7169
7170 C...Find incoming four-vectors to subprocess.
7171         K(N+1,1)=21
7172         IF(MINT(141).NE.0) THEN
7173           DO 220 J=1,4
7174             P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7175   220     CONTINUE
7176         ELSE
7177           DO 230 J=1,4
7178             P(N+1,J)=P(MINT(83)+1,J)
7179   230     CONTINUE
7180         ENDIF
7181         K(N+2,1)=21
7182         IF(MINT(142).NE.0) THEN
7183           DO 240 J=1,4
7184             P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7185   240     CONTINUE
7186         ELSE
7187           DO 250 J=1,4
7188             P(N+2,J)=P(MINT(83)+2,J)
7189   250     CONTINUE
7190         ENDIF
7191
7192 C...Define boost and rotation between hadronic subsystem and
7193 C...collision rest frame; boost hadronic subsystem to this frame.
7194         DO 260 J=1,3
7195           BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7196   260   CONTINUE
7197         CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7198         BPHI=PYANGL(P(N+1,1),P(N+1,2))
7199         CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7200         BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7201         CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7202      &  BETA(3))
7203
7204 C...Add on scattered leptons to final state.
7205         DO 280 I=1,2
7206           IF(MINT(140+I).NE.0) THEN
7207             LSC=MINT(83)+MIN(I+2,MOVE)
7208             N=N+1
7209             DO 270 J=1,5
7210               K(N,J)=K(LSC,J)
7211               P(N,J)=P(LSC,J)
7212               V(N,J)=V(LSC,J)
7213   270       CONTINUE
7214             K(N,1)=1
7215             K(N,3)=LSC
7216           ENDIF
7217   280   CONTINUE
7218       ENDIF
7219
7220       RETURN
7221       END
7222
7223 C*********************************************************************
7224
7225 C...PYRAND
7226 C...Generates quantities characterizing the high-pT scattering at the
7227 C...parton level according to the matrix elements. Chooses incoming,
7228 C...reacting partons, their momentum fractions and one of the possible
7229 C...subprocesses.
7230
7231       SUBROUTINE PYRAND
7232
7233 C...Double precision and integer declarations.
7234       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7235       IMPLICIT INTEGER(I-N)
7236       INTEGER PYK,PYCHGE,PYCOMP
7237 C...Parameter statement to help give large particle numbers.
7238       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7239      &KEXCIT=4000000,KDIMEN=5000000)
7240
7241 C...User process initialization and event commonblocks.
7242       INTEGER MAXPUP
7243       PARAMETER (MAXPUP=100)
7244       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7245       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7246       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7247      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7248      &LPRUP(MAXPUP)
7249       INTEGER MAXNUP
7250       PARAMETER (MAXNUP=500)
7251       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7252       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7253       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7254      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7255      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7256       SAVE /HEPRUP/,/HEPEUP/
7257
7258 C...Commonblocks.
7259       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7260       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7261       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7262       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7263       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7264       COMMON/PYINT1/MINT(400),VINT(400)
7265       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7266       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7267       COMMON/PYINT4/MWID(500),WIDS(500,5)
7268       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7269       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7270       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7271       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7272      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7273 C...Local arrays.
7274       DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7275
7276 C...Parameters and data used in elastic/diffractive treatment.
7277       DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7278      &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7279
7280 C...Initial values, specifically for (first) semihard interaction.
7281       MINT(10)=0
7282       MINT(17)=0
7283       MINT(18)=0
7284       VINT(97)=1D0
7285       VINT(143)=1D0
7286       VINT(144)=1D0
7287       VINT(157)=0D0
7288       VINT(158)=0D0
7289       MFAIL=0
7290       IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7291       ISUB=0
7292       ISTSB=0
7293       LOOP=0
7294   100 LOOP=LOOP+1
7295       MINT(51)=0
7296       MINT(143)=1
7297
7298 C...Start by assuming incoming photon is entering subprocess.
7299       IF(MINT(11).EQ.22) THEN
7300          MINT(15)=22
7301          VINT(307)=VINT(3)**2
7302       ENDIF
7303       IF(MINT(12).EQ.22) THEN
7304          MINT(16)=22
7305          VINT(308)=VINT(4)**2
7306       ENDIF
7307       MINT(103)=MINT(11)
7308       MINT(104)=MINT(12)
7309
7310 C...Choice of process type - first event of pileup.
7311       INMULT=0
7312       IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7313       ELSEIF(MINT(82).EQ.1) THEN
7314
7315 C...For gamma-p or gamma-gamma first pick between alternatives.
7316         IGA=0
7317         IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7318         MINT(122)=IGA
7319
7320 C...For real gamma + gamma with different nature, flip at random.
7321         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7322      &  MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7323           MINTSV=MINT(41)
7324           MINT(41)=MINT(42)
7325           MINT(42)=MINTSV
7326           MINTSV=MINT(45)
7327           MINT(45)=MINT(46)
7328           MINT(46)=MINTSV
7329           MINTSV=MINT(107)
7330           MINT(107)=MINT(108)
7331           MINT(108)=MINTSV
7332           IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7333         ENDIF
7334
7335 C...Pick process type, possibly by user process machinery.
7336 C...(If the latter, also event will be picked here.)
7337         IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7338           CALL UPEVNT
7339         ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7340           CALL UPEVNT
7341           ISUB=0
7342   110     ISUB=ISUB+1
7343           IF(KFPR(ISUB,2).NE.IDPRUP.AND.ISUB.LT.500) GOTO 110
7344         ELSE
7345           RSUB=XSEC(0,1)*PYR(0)
7346           DO 120 I=1,500
7347             IF(MSUB(I).NE.1) GOTO 120
7348             ISUB=I
7349             RSUB=RSUB-XSEC(I,1)
7350             IF(RSUB.LE.0D0) GOTO 130
7351   120     CONTINUE
7352   130     IF(ISUB.EQ.95) ISUB=96
7353           IF(ISUB.EQ.96) INMULT=1
7354           IF(ISET(ISUB).EQ.11) THEN
7355             IDPRUP=KFPR(ISUB,2)
7356             CALL UPEVNT
7357           ENDIF
7358         ENDIF
7359
7360 C...Choice of inclusive process type - pileup events.
7361       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7362         RSUB=VINT(131)*PYR(0)
7363         ISUB=96
7364         IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7365         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7366         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7367         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7368      &  ISUB=91
7369         IF(ISUB.EQ.96) INMULT=1
7370       ENDIF
7371
7372 C...Choice of photon energy and flux factor inside lepton.
7373       IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7374         CALL PYGAGA(3,WTGAGA)
7375         IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7376           CKIN(3)=MAX(VINT(285),VINT(154))
7377           CKIN(1)=2D0*CKIN(3)
7378         ENDIF
7379 C...When necessary set direct/resolved photon by hand.
7380       ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7381         IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7382         IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7383       ENDIF
7384
7385 C...Restrict direct*resolved processes to pTmin >= Q,
7386 C...to avoid doublecounting  with DIS.
7387       IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7388         IF(MINT(15).EQ.22) THEN
7389           CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7390         ELSE
7391           CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7392         ENDIF
7393         CKIN(1)=2D0*CKIN(3)
7394       ENDIF
7395
7396 C...Set up for multiple interactions.
7397       IF(INMULT.EQ.1) CALL PYMULT(2)
7398
7399 C...Loopback point for minimum bias in photon physics.
7400       LOOP2=0
7401   140 LOOP2=LOOP2+1
7402       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7403       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7404       IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7405      &NGEN(97,1)=NGEN(97,1)+MINT(143)
7406       MINT(1)=ISUB
7407       ISTSB=ISET(ISUB)
7408
7409 C...Random choice of flavour for some SUSY processes.
7410       IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7411 C...~e_L ~nu_e or ~mu_L ~nu_mu.
7412         IF(ISUB.EQ.210) THEN
7413           KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7414           KFPR(ISUB,2)=KFPR(ISUB,1)+1
7415 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7416         ELSEIF(ISUB.EQ.213) THEN
7417           KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7418           KFPR(ISUB,2)=KFPR(ISUB,1)
7419 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7420         ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7421           IF(ISUB.GE.258) THEN
7422             RKF=4D0
7423           ELSE
7424             RKF=5D0
7425           ENDIF
7426           IF(MOD(ISUB,2).EQ.0) THEN
7427             KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7428           ELSE
7429             KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7430           ENDIF
7431 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7432         ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7433           IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7434             KSU1=KSUSY1
7435             KSU2=KSUSY1
7436           ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7437             KSU1=KSUSY2
7438             KSU2=KSUSY2
7439           ELSEIF(PYR(0).LT.0.5D0) THEN
7440             KSU1=KSUSY1
7441             KSU2=KSUSY2
7442           ELSE
7443             KSU1=KSUSY2
7444             KSU2=KSUSY1
7445           ENDIF
7446           KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7447           KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7448 C...~q ~q(bar);  ~q = ~d, ~u, ~s, or ~c.
7449         ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7450           KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7451           KFPR(ISUB,2)=KFPR(ISUB,1)
7452         ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7453           KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7454           KFPR(ISUB,2)=KFPR(ISUB,1)
7455 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7456         ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7457           IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7458             KSU1=KSUSY1
7459             KSU2=KSUSY1
7460           ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7461             KSU1=KSUSY2
7462             KSU2=KSUSY2
7463           ELSEIF(PYR(0).LT.0.5D0) THEN
7464             KSU1=KSUSY1
7465             KSU2=KSUSY2
7466           ELSE
7467             KSU1=KSUSY2
7468             KSU2=KSUSY1
7469           ENDIF
7470           IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7471             RKF=5D0
7472           ELSE
7473             RKF=4D0
7474           ENDIF
7475           KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7476         ENDIF
7477       ENDIF
7478
7479 C...Find resonances (explicit or implicit in cross-section).
7480       MINT(72)=0
7481       KFR1=0
7482       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7483         KFR1=KFPR(ISUB,1)
7484       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7485      &  ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7486         KFR1=23
7487       ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7488      &  ISUB.EQ.177) THEN
7489         KFR1=24
7490       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7491         KFR1=25
7492         IF(MSTP(46).EQ.5) THEN
7493           KFR1=89
7494           PMAS(89,1)=PARP(45)
7495           PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7496         ENDIF
7497       ELSEIF(ISUB.EQ.194) THEN
7498         KFR1=KTECHN+113
7499       ELSEIF(ISUB.EQ.195) THEN
7500         KFR1=KTECHN+213
7501       ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7502         KFR1=KTECHN+113
7503       ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7504         KFR1=KTECHN+213
7505       ENDIF
7506       CKMX=CKIN(2)
7507       IF(CKMX.LE.0D0) CKMX=VINT(1)
7508       KCR1=PYCOMP(KFR1)
7509       IF(KFR1.NE.0) THEN
7510         IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7511      &  CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7512       ENDIF
7513       IF(KFR1.NE.0) THEN
7514         TAUR1=PMAS(KCR1,1)**2/VINT(2)
7515         IF(KFR1.EQ.KTECHN+113) THEN
7516           CALL PYTECM(S1,S2)
7517           TAUR1=S1/VINT(2)
7518         ENDIF
7519         GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7520         MINT(72)=1
7521         MINT(73)=KFR1
7522         VINT(73)=TAUR1
7523         VINT(74)=GAMR1
7524       ENDIF
7525       IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7526      $THEN
7527         KFR2=23
7528         IF(ISUB.EQ.194) THEN
7529           KFR2=KTECHN+223
7530         ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7531           KFR2=KTECHN+223
7532         ENDIF
7533         KCR2=PYCOMP(KFR2)
7534         TAUR2=PMAS(KCR2,1)**2/VINT(2)
7535         IF(KFR2.EQ.KTECHN+223) THEN
7536           CALL PYTECM(S1,S2)
7537           TAUR2=S2/VINT(2)
7538         ENDIF
7539         GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7540         IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7541      &  CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7542         IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7543           MINT(72)=2
7544           MINT(74)=KFR2
7545           VINT(75)=TAUR2
7546           VINT(76)=GAMR2
7547         ELSEIF(KFR2.NE.0) THEN
7548           KFR1=KFR2
7549           TAUR1=TAUR2
7550           GAMR1=GAMR2
7551           MINT(72)=1
7552           MINT(73)=KFR1
7553           VINT(73)=TAUR1
7554           VINT(74)=GAMR1
7555         ENDIF
7556       ENDIF
7557
7558 C...Find product masses and minimum pT of process,
7559 C...optionally with broadening according to a truncated Breit-Wigner.
7560       VINT(63)=0D0
7561       VINT(64)=0D0
7562       MINT(71)=0
7563       VINT(71)=CKIN(3)
7564       IF(MINT(82).GE.2) VINT(71)=0D0
7565       VINT(80)=1D0
7566       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7567         NBW=0
7568         DO 160 I=1,2
7569           PMMN(I)=0D0
7570           IF(KFPR(ISUB,I).EQ.0) THEN
7571           ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7572      &      PARP(41)) THEN
7573             VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7574           ELSE
7575             NBW=NBW+1
7576 C...This prevents SUSY/t particles from becoming too light.
7577             KFLW=KFPR(ISUB,I)
7578             IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7579               KCW=PYCOMP(KFLW)
7580               PMMN(I)=PMAS(KCW,1)
7581               DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7582                 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7583                   PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7584      &            PMAS(PYCOMP(KFDP(IDC,2)),1)
7585                   IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7586      &            PMAS(PYCOMP(KFDP(IDC,3)),1)
7587                   PMMN(I)=MIN(PMMN(I),PMSUM)
7588                 ENDIF
7589   150         CONTINUE
7590             ELSEIF(KFLW.EQ.6) THEN
7591               PMMN(I)=PMAS(24,1)+PMAS(5,1)
7592             ENDIF
7593           ENDIF
7594   160   CONTINUE
7595         IF(NBW.GE.1) THEN
7596           CKIN41=CKIN(41)
7597           CKIN43=CKIN(43)
7598           CKIN(41)=MAX(PMMN(1),CKIN(41))
7599           CKIN(43)=MAX(PMMN(2),CKIN(43))
7600           CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7601           CKIN(41)=CKIN41
7602           CKIN(43)=CKIN43
7603           IF(MINT(51).EQ.1) THEN
7604             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7605             IF(MFAIL.EQ.1) THEN
7606               MSTI(61)=1
7607               RETURN
7608             ENDIF
7609             GOTO 100
7610           ENDIF
7611           VINT(63)=PQM3**2
7612           VINT(64)=PQM4**2
7613         ENDIF
7614         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7615         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7616       ENDIF
7617
7618 C...Prepare for additional variable choices in 2 -> 3.
7619       IF(ISTSB.EQ.5) THEN
7620         VINT(201)=0D0
7621         IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7622         VINT(206)=VINT(201)
7623         VINT(204)=PMAS(23,1)
7624         IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7625         IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7626         IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7627      &  ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7628         VINT(209)=VINT(204)
7629       ENDIF
7630
7631 C...Select incoming VDM particle (rho/omega/phi/J/psi).
7632       IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7633      &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7634         VRN=PYR(0)*SIGT(0,0,5)
7635         IF(MINT(101).LE.1) THEN
7636           I1MN=0
7637           I1MX=0
7638         ELSE
7639           I1MN=1
7640           I1MX=MINT(101)
7641         ENDIF
7642         IF(MINT(102).LE.1) THEN
7643           I2MN=0
7644           I2MX=0
7645         ELSE
7646           I2MN=1
7647           I2MX=MINT(102)
7648         ENDIF
7649         DO 180 I1=I1MN,I1MX
7650           KFV1=110*I1+3
7651           DO 170 I2=I2MN,I2MX
7652             KFV2=110*I2+3
7653             VRN=VRN-SIGT(I1,I2,5)
7654             IF(VRN.LE.0D0) GOTO 190
7655   170     CONTINUE
7656   180   CONTINUE
7657   190   IF(MINT(101).GE.2) MINT(103)=KFV1
7658         IF(MINT(102).GE.2) MINT(104)=KFV2
7659       ENDIF
7660
7661       IF(ISTSB.EQ.0) THEN
7662 C...Elastic scattering or single or double diffractive scattering.
7663
7664 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7665         MINT(103)=MINT(11)
7666         MINT(104)=MINT(12)
7667         PMM(1)=VINT(3)
7668         PMM(2)=VINT(4)
7669         IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7670           JJ=ISUB-90
7671           VRN=PYR(0)*SIGT(0,0,JJ)
7672           IF(MINT(101).LE.1) THEN
7673             I1MN=0
7674             I1MX=0
7675           ELSE
7676             I1MN=1
7677             I1MX=MINT(101)
7678           ENDIF
7679           IF(MINT(102).LE.1) THEN
7680             I2MN=0
7681             I2MX=0
7682           ELSE
7683             I2MN=1
7684             I2MX=MINT(102)
7685           ENDIF
7686           DO 210 I1=I1MN,I1MX
7687             KFV1=110*I1+3
7688             DO 200 I2=I2MN,I2MX
7689               KFV2=110*I2+3
7690               VRN=VRN-SIGT(I1,I2,JJ)
7691               IF(VRN.LE.0D0) GOTO 220
7692   200       CONTINUE
7693   210     CONTINUE
7694   220     IF(MINT(101).GE.2) THEN
7695             MINT(103)=KFV1
7696             PMM(1)=PYMASS(KFV1)
7697           ENDIF
7698           IF(MINT(102).GE.2) THEN
7699             MINT(104)=KFV2
7700             PMM(2)=PYMASS(KFV2)
7701           ENDIF
7702         ENDIF
7703         VINT(67)=PMM(1)
7704         VINT(68)=PMM(2)
7705
7706 C...Select mass for GVMD states (rejecting previous assignment).
7707         Q0S=4D0*PARP(15)**2
7708         Q1S=4D0*VINT(154)**2
7709         LOOP3=0
7710   230   LOOP3=LOOP3+1
7711         DO 240 JT=1,2
7712           IF(MINT(106+JT).EQ.3) THEN
7713             PS=VINT(2+JT)**2
7714             PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7715      &      (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7716             IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7717      &      PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7718           ENDIF
7719   240   CONTINUE
7720         IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7721           IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7722      &    GOTO 230
7723           GOTO 100
7724         ENDIF
7725
7726 C...Side/sides of diffractive system.
7727         MINT(17)=0
7728         MINT(18)=0
7729         IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7730         IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7731
7732 C...Find masses of particles and minimal masses of diffractive states.
7733         DO 250 JT=1,2
7734           PDIF(JT)=PMM(JT)
7735           VINT(68+JT)=PDIF(JT)
7736           IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7737   250   CONTINUE
7738         SH=VINT(2)
7739         SQM1=PMM(1)**2
7740         SQM2=PMM(2)**2
7741         SQM3=PDIF(1)**2
7742         SQM4=PDIF(2)**2
7743         SMRES1=(PMM(1)+PMRC)**2
7744         SMRES2=(PMM(2)+PMRC)**2
7745
7746 C...Find elastic slope and lower limit diffractive slope.
7747         IHA=MAX(2,IABS(MINT(103))/110)
7748         IF(IHA.GE.5) IHA=1
7749         IHB=MAX(2,IABS(MINT(104))/110)
7750         IF(IHB.GE.5) IHB=1
7751         IF(ISUB.EQ.91) THEN
7752           BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7753         ELSEIF(ISUB.EQ.92) THEN
7754           BMN=MAX(2D0,2D0*BHAD(IHB))
7755         ELSEIF(ISUB.EQ.93) THEN
7756           BMN=MAX(2D0,2D0*BHAD(IHA))
7757         ELSEIF(ISUB.EQ.94) THEN
7758           BMN=2D0*ALP*4D0
7759         ENDIF
7760
7761 C...Determine maximum possible t range and coefficient of generation.
7762         SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7763         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7764         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7765         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7766         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7767      &  (SQM1*SQM4-SQM2*SQM3)/SH
7768         THL=-0.5D0*(THA+THB)
7769         THU=THC/THL
7770         THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7771
7772 C...Select diffractive mass/masses according to dm^2/m^2.
7773         LOOP3=0
7774   260   LOOP3=LOOP3+1
7775         DO 270 JT=1,2
7776           IF(MINT(16+JT).EQ.0) THEN
7777             PDIF(2+JT)=PDIF(JT)
7778           ELSE
7779             PMMIN=PDIF(JT)
7780             PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7781             PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7782           ENDIF
7783   270   CONTINUE
7784         SQM3=PDIF(3)**2
7785         SQM4=PDIF(4)**2
7786
7787 C..Additional mass factors, including resonance enhancement.
7788         IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7789           IF(LOOP3.LT.100) GOTO 260
7790           GOTO 100
7791         ENDIF
7792         IF(ISUB.EQ.92) THEN
7793           FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7794           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7795         ELSEIF(ISUB.EQ.93) THEN
7796           FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7797           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7798         ELSEIF(ISUB.EQ.94) THEN
7799           FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7800      &    (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7801      &    (1D0+CRES*SMRES2/(SMRES2+SQM4))
7802           IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7803         ENDIF
7804
7805 C...Select t according to exp(Bmn*t) and correct to right slope.
7806         TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7807         IF(ISUB.GE.92) THEN
7808           IF(ISUB.EQ.92) THEN
7809             BADD=2D0*ALP*LOG(SH/SQM3)
7810             IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7811           ELSEIF(ISUB.EQ.93) THEN
7812             BADD=2D0*ALP*LOG(SH/SQM4)
7813             IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7814           ELSEIF(ISUB.EQ.94) THEN
7815             BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7816           ENDIF
7817           IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7818         ENDIF
7819
7820 C...Check whether m^2 and t choices are consistent.
7821         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7822         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7823         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7824         IF(THB.LE.1D-8) GOTO 260
7825         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7826      &  (SQM1*SQM4-SQM2*SQM3)/SH
7827         THLM=-0.5D0*(THA+THB)
7828         THUM=THC/THLM
7829         IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7830
7831 C...Information to output.
7832         VINT(21)=1D0
7833         VINT(22)=0D0
7834         VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7835         VINT(45)=TH
7836         VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7837         VINT(63)=PDIF(3)**2
7838         VINT(64)=PDIF(4)**2
7839         VINT(283)=PMM(1)**2/4D0
7840         VINT(284)=PMM(2)**2/4D0
7841
7842 C...Note: in the following, by In is meant the integral over the
7843 C...quantity multiplying coefficient cn.
7844 C...Choose tau according to h1(tau)/tau, where
7845 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7846 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7847 C...I1/I5*c5*1/(tau+tau_R') +
7848 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7849 C...I1/I7*c7*tau/(1.-tau), and
7850 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7851       ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
7852         CALL PYKLIM(1)
7853         IF(MINT(51).NE.0) THEN
7854           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7855           IF(MFAIL.EQ.1) THEN
7856             MSTI(61)=1
7857             RETURN
7858           ENDIF
7859           GOTO 100
7860         ENDIF
7861         RTAU=PYR(0)
7862         MTAU=1
7863         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7864         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7865         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7866         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7867      &  MTAU=5
7868         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7869      &  COEF(ISUB,5)) MTAU=6
7870         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7871      &  COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
7872         CALL PYKMAP(1,MTAU,PYR(0))
7873
7874 C...2 -> 3, 4 processes:
7875 C...Choose tau' according to h4(tau,tau')/tau', where
7876 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7877 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7878         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7879           CALL PYKLIM(4)
7880           IF(MINT(51).NE.0) THEN
7881             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7882             IF(MFAIL.EQ.1) THEN
7883               MSTI(61)=1
7884               RETURN
7885             ENDIF
7886             GOTO 100
7887           ENDIF
7888           RTAUP=PYR(0)
7889           MTAUP=1
7890           IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
7891           IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
7892           CALL PYKMAP(4,MTAUP,PYR(0))
7893         ENDIF
7894
7895 C...Choose y* according to h2(y*), where
7896 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7897 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7898 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7899 C...and c1 + c2 + c3 + c4 + c5 = 1.
7900         CALL PYKLIM(2)
7901         IF(MINT(51).NE.0) THEN
7902           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7903           IF(MFAIL.EQ.1) THEN
7904             MSTI(61)=1
7905             RETURN
7906           ENDIF
7907           GOTO 100
7908         ENDIF
7909         RYST=PYR(0)
7910         MYST=1
7911         IF(RYST.GT.COEF(ISUB,8)) MYST=2
7912         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
7913         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
7914         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
7915      &  COEF(ISUB,11)) MYST=5
7916         CALL PYKMAP(2,MYST,PYR(0))
7917
7918 C...2 -> 2 processes:
7919 C...Choose cos(theta-hat) (cth) according to h3(cth), where
7920 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7921 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7922 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7923 C...and c0 + c1 + c2 + c3 + c4 = 1.
7924         CALL PYKLIM(3)
7925         IF(MINT(51).NE.0) THEN
7926           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7927           IF(MFAIL.EQ.1) THEN
7928             MSTI(61)=1
7929             RETURN
7930           ENDIF
7931           GOTO 100
7932         ENDIF
7933         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7934           RCTH=PYR(0)
7935           MCTH=1
7936           IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
7937           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
7938           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
7939           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
7940      &    COEF(ISUB,16)) MCTH=5
7941           CALL PYKMAP(3,MCTH,PYR(0))
7942         ENDIF
7943
7944 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7945         IF(ISTSB.EQ.5) THEN
7946           CALL PYKMAP(5,0,0D0)
7947           IF(MINT(51).NE.0) THEN
7948             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7949             IF(MFAIL.EQ.1) THEN
7950               MSTI(61)=1
7951               RETURN
7952             ENDIF
7953             GOTO 100
7954           ENDIF
7955         ENDIF
7956
7957 C...DIS as f + gamma* -> f process: set dummy values.
7958       ELSEIF(ISTSB.EQ.8) THEN
7959         VINT(21)=0.9D0
7960         VINT(22)=0D0
7961         VINT(23)=0D0
7962         VINT(47)=0D0
7963         VINT(48)=0D0
7964
7965 C...Low-pT or multiple interactions (first semihard interaction).
7966       ELSEIF(ISTSB.EQ.9) THEN
7967         CALL PYMULT(3)
7968         ISUB=MINT(1)
7969
7970 C...Study user-defined process: kinematics plus weight.
7971       ELSEIF(ISTSB.EQ.11) THEN
7972         IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
7973      &  PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
7974         MSTI(51)=0
7975         IF(NUP.LE.0) THEN
7976           MINT(51)=2
7977           MSTI(51)=1
7978           IF(MINT(82).EQ.1) THEN
7979             NGEN(0,1)=NGEN(0,1)-1
7980             NGEN(ISUB,1)=NGEN(ISUB,1)-1
7981           ENDIF
7982           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7983           RETURN
7984         ENDIF
7985
7986 C...Extract cross section event weight.
7987         IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
7988           SIGS=1D-9*XWGTUP
7989         ELSE
7990           SIGS=1D-9*XSECUP(KFPR(ISUB,1))
7991         ENDIF
7992         IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
7993           VINT(97)=SIGN(1D0,XWGTUP)
7994         ELSE
7995           VINT(97)=1D-9*XWGTUP
7996         ENDIF
7997
7998 C...Construct 'trivial' kinematical variables needed.
7999         KFL1=IDUP(1)
8000         KFL2=IDUP(2)
8001         VINT(41)=PUP(4,1)/EBMUP(1)
8002         VINT(42)=PUP(4,2)/EBMUP(2)
8003         VINT(21)=VINT(41)*VINT(42)
8004         VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8005         VINT(44)=VINT(21)*VINT(2)
8006         VINT(43)=SQRT(MAX(0D0,VINT(44)))
8007         VINT(55)=SCALUP
8008         IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8009         VINT(56)=VINT(55)**2
8010         VINT(57)=AQEDUP
8011         VINT(58)=AQCDUP
8012
8013 C...Construct other kinematical variables needed (approximately).
8014         VINT(23)=0D0
8015         VINT(26)=VINT(21)
8016         VINT(45)=-0.5D0*VINT(44)
8017         VINT(46)=-0.5D0*VINT(44)
8018         VINT(49)=VINT(43)
8019         VINT(50)=VINT(44)
8020         VINT(51)=VINT(55)
8021         VINT(52)=VINT(56)
8022         VINT(53)=VINT(55)
8023         VINT(54)=VINT(56)
8024         VINT(25)=0D0
8025         VINT(48)=0D0
8026         IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8027      &  '(PYRAND:) unacceptable ISTUP code for incoming particles')
8028         DO 280 IUP=3,NUP
8029           IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8030      &    '(PYRAND:) unacceptable ISTUP code for particles')
8031           IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8032      &    PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8033           IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8034      &    PUP(2,IUP)**2)
8035   280   CONTINUE
8036         VINT(47)=SQRT(VINT(48))
8037       ENDIF
8038
8039 C...Choose azimuthal angle.
8040       VINT(24)=0D0
8041       IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8042
8043 C...Check against user cuts on kinematics at parton level.
8044       MINT(51)=0
8045       IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8046       IF(MINT(51).NE.0) THEN
8047         IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8048         IF(MFAIL.EQ.1) THEN
8049           MSTI(61)=1
8050           RETURN
8051         ENDIF
8052         GOTO 100
8053       ENDIF
8054       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8055         MCUT=0
8056         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8057      &  CALL PYKCUT(MCUT)
8058         IF(MCUT.NE.0) THEN
8059           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8060           IF(MFAIL.EQ.1) THEN
8061             MSTI(61)=1
8062             RETURN
8063           ENDIF
8064           GOTO 100
8065         ENDIF
8066       ENDIF
8067
8068 C...Calculate differential cross-section for different subprocesses.
8069       IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8070       SIGSOR=SIGS
8071       SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8072
8073 C...Multiply cross section by lepton -> photon flux factor.
8074       IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8075         SIGS=WTGAGA*SIGS
8076         DO 290 ICHN=1,NCHN
8077           SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8078   290   CONTINUE
8079         SIGLPT=WTGAGA*SIGLPT
8080       ENDIF
8081
8082 C...Multiply cross-section by user-defined weights.
8083       IF(MSTP(173).EQ.1) THEN
8084         SIGS=PARP(173)*SIGS
8085         DO 300 ICHN=1,NCHN
8086           SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8087   300   CONTINUE
8088         SIGLPT=PARP(173)*SIGLPT
8089       ENDIF
8090       WTXS=1D0
8091       SIGSWT=SIGS
8092       VINT(99)=1D0
8093       VINT(100)=1D0
8094       IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8095         IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8096      &  MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8097         SIGSWT=WTXS*SIGS
8098         VINT(99)=WTXS
8099         IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8100       ENDIF
8101
8102 C...Calculations for Monte Carlo estimate of all cross-sections.
8103       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8104         IF(MSTP(142).LE.1) THEN
8105           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8106         ELSE
8107           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8108         ENDIF
8109       ELSEIF(MINT(82).EQ.1) THEN
8110         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8111       ENDIF
8112       IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8113      &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8114
8115 C...Multiple interactions: store results of cross-section calculation.
8116       IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8117         VINT(153)=SIGSOR
8118         CALL PYMULT(4)
8119       ENDIF
8120
8121 C...Ratio of actual to maximum cross section.
8122       IF(ISTSB.NE.11) THEN
8123         VIOL=SIGSWT/XSEC(ISUB,1)
8124         IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8125       ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8126         VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8127       ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8128         VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8129       ELSE
8130         VIOL=1D0
8131       ENDIF
8132
8133 C...Check that weight not negative.
8134       IF(MSTP(123).LE.0) THEN
8135         IF(VIOL.LT.-1D-3) THEN
8136           WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8137           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8138      &    VINT(22),VINT(23),VINT(26)
8139           STOP
8140         ENDIF
8141       ELSE
8142         IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8143           VINT(109)=VIOL
8144           WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8145           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8146      &    VINT(22),VINT(23),VINT(26)
8147         ENDIF
8148       ENDIF
8149
8150 C...Weighting using estimate of maximum of differential cross-section.
8151       IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8152         IF(VIOL.LT.PYR(0)) THEN
8153           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8154           IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8155           GOTO 100
8156         ENDIF
8157       ELSEIF(MFAIL.EQ.0) THEN
8158         RATND=SIGLPT/XSEC(95,1)
8159         IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8160           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8161           ISUB=0
8162           GOTO 100
8163         ENDIF
8164         VIOL=VIOL/RATND
8165         IF(VIOL.LT.PYR(0)) THEN
8166           GOTO 140
8167         ENDIF
8168       ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8169         IF(VIOL.LT.PYR(0)) THEN
8170           MSTI(61)=1
8171           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8172           RETURN
8173         ENDIF
8174       ELSE
8175         RATND=SIGLPT/XSEC(95,1)
8176         IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8177           MSTI(61)=1
8178           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8179           RETURN
8180         ENDIF
8181         VIOL=VIOL/RATND
8182         IF(VIOL.LT.PYR(0)) THEN
8183           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8184           GOTO 100
8185         ENDIF
8186       ENDIF
8187
8188 C...Check for possible violation of estimated maximum of differential
8189 C...cross-section used in weighting.
8190       IF(MSTP(123).LE.0) THEN
8191         IF(VIOL.GT.1D0) THEN
8192           WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8193           IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8194      &    VINT(22),VINT(23),VINT(26)
8195           STOP
8196         ENDIF
8197       ELSEIF(MSTP(123).EQ.1) THEN
8198         IF(VIOL.GT.VINT(108)) THEN
8199           VINT(108)=VIOL
8200           IF(VIOL.GT.1.0001D0) THEN
8201             MINT(10)=1
8202             WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8203             IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8204      &      VINT(22),VINT(23),VINT(26)
8205           ENDIF
8206         ENDIF
8207       ELSEIF(VIOL.GT.VINT(108)) THEN
8208         VINT(108)=VIOL
8209         IF(VIOL.GT.1D0) THEN
8210           MINT(10)=1
8211           WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8212           IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8213      &    THEN
8214             XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8215             IF(KFPR(ISUB,1).LE.9) THEN
8216               WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8217             ELSEIF(KFPR(ISUB,1).LE.99) THEN
8218               WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8219             ELSE
8220               WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8221             ENDIF
8222           ENDIF
8223           IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8224             XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8225             XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8226             IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8227      &      XSEC(0,1)=XSEC(0,1)+XDIF
8228             IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8229      &      VINT(22),VINT(23),VINT(26)
8230             IF(ISUB.LE.9) THEN
8231               WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8232             ELSEIF(ISUB.LE.99) THEN
8233               WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8234             ELSE
8235               WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8236             ENDIF
8237           ENDIF
8238           VINT(108)=1D0
8239         ENDIF
8240       ENDIF
8241
8242 C...Multiple interactions: choose impact parameter.
8243       VINT(148)=1D0
8244       IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8245      &MSTP(82).GE.3) THEN
8246         CALL PYMULT(5)
8247         IF(VINT(150).LT.PYR(0)) THEN
8248           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8249           IF(MFAIL.EQ.1) THEN
8250             MSTI(61)=1
8251             RETURN
8252           ENDIF
8253           GOTO 100
8254         ENDIF
8255       ENDIF
8256       IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8257       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8258         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8259         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8260       ENDIF
8261       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8262
8263 C...Choose flavour of reacting partons (and subprocess).
8264       IF(ISTSB.GE.11) GOTO 320
8265       RSIGS=SIGS*PYR(0)
8266       QT2=VINT(48)
8267       RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8268      &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8269       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8270      &PYR(0).GT.RQQBAR)) THEN
8271         DO 310 ICHN=1,NCHN
8272           KFL1=ISIG(ICHN,1)
8273           KFL2=ISIG(ICHN,2)
8274           MINT(2)=ISIG(ICHN,3)
8275           RSIGS=RSIGS-SIGH(ICHN)
8276           IF(RSIGS.LE.0D0) GOTO 320
8277   310   CONTINUE
8278
8279 C...Multiple interactions: choose qqbar preferentially at small pT.
8280       ELSEIF(ISUB.EQ.96) THEN
8281         MINT(105)=MINT(103)
8282         MINT(109)=MINT(107)
8283         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8284         MINT(105)=MINT(104)
8285         MINT(109)=MINT(108)
8286         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8287         MINT(1)=11
8288         MINT(2)=1
8289         IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8290
8291 C...Low-pT: choose string drawing configuration.
8292       ELSE
8293         KFL1=21
8294         KFL2=21
8295         RSIGS=6D0*PYR(0)
8296         MINT(2)=1
8297         IF(RSIGS.GT.1D0) MINT(2)=2
8298         IF(RSIGS.GT.2D0) MINT(2)=3
8299       ENDIF
8300
8301 C...Reassign QCD process. Partons before initial state radiation.
8302   320 IF(MINT(2).GT.10) THEN
8303         MINT(1)=MINT(2)/10
8304         MINT(2)=MOD(MINT(2),10)
8305       ENDIF
8306       IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8307      &NGEN(MINT(1),2)+1
8308       MINT(15)=KFL1
8309       MINT(16)=KFL2
8310       MINT(13)=MINT(15)
8311       MINT(14)=MINT(16)
8312       VINT(141)=VINT(41)
8313       VINT(142)=VINT(42)
8314       VINT(151)=0D0
8315       VINT(152)=0D0
8316
8317 C...Calculate x value of photon for parton inside photon inside e.
8318       DO 350 JT=1,2
8319         MINT(18+JT)=0
8320         VINT(154+JT)=0D0
8321         MSPLI=0
8322         IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8323         IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8324         IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8325         IF(MSPLI.EQ.2) THEN
8326           KFLH=MINT(14+JT)
8327           XHRD=VINT(140+JT)
8328           Q2HRD=VINT(54)
8329           MINT(105)=MINT(102+JT)
8330           MINT(109)=MINT(106+JT)
8331           VINT(120)=VINT(2+JT)
8332           IF(MSTP(57).LE.1) THEN
8333             CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8334           ELSE
8335             CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8336           ENDIF
8337           WTMX=4D0*XPQ(KFLH)
8338           IF(MSTP(13).EQ.2) THEN
8339             Q2PMS=Q2HRD/PMAS(11,1)**2
8340             WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8341           ENDIF
8342   330     XE=XHRD**PYR(0)
8343           XG=MIN(1D0-1D-10,XHRD/XE)
8344           IF(MSTP(57).LE.1) THEN
8345             CALL PYPDFU(22,XG,Q2HRD,XPQ)
8346           ELSE
8347             CALL PYPDFL(22,XG,Q2HRD,XPQ)
8348           ENDIF
8349           WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8350           IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8351           IF(WT.LT.PYR(0)*WTMX) GOTO 330
8352           MINT(18+JT)=1
8353           VINT(154+JT)=XE
8354           DO 340 KFLS=-25,25
8355             XSFX(JT,KFLS)=XPQ(KFLS)
8356   340     CONTINUE
8357         ENDIF
8358   350 CONTINUE
8359
8360 C...Pick scale where photon is resolved.
8361       Q0S=PARP(15)**2
8362       Q1S=VINT(154)**2
8363       VINT(283)=0D0
8364       IF(MINT(107).EQ.3) THEN
8365         IF(MSTP(66).EQ.1) THEN
8366           VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8367         ELSEIF(MSTP(66).EQ.2) THEN
8368           PS=VINT(3)**2
8369           Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8370      &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8371           Q2INT=SQRT(Q0S*Q2EFF)
8372           VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8373         ELSEIF(MSTP(66).EQ.3) THEN
8374           VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8375         ELSEIF(MSTP(66).GE.4) THEN
8376           PS=0.25D0*VINT(3)**2
8377           VINT(283)=(Q0S+PS)*(Q1S+PS)/
8378      &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8379         ENDIF
8380       ENDIF
8381       VINT(284)=0D0
8382       IF(MINT(108).EQ.3) THEN
8383         IF(MSTP(66).EQ.1) THEN
8384           VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8385         ELSEIF(MSTP(66).EQ.2) THEN
8386           PS=VINT(4)**2
8387           Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8388      &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8389           Q2INT=SQRT(Q0S*Q2EFF)
8390           VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8391         ELSEIF(MSTP(66).EQ.3) THEN
8392           VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8393         ELSEIF(MSTP(66).GE.4) THEN
8394           PS=0.25D0*VINT(4)**2
8395           VINT(284)=(Q0S+PS)*(Q1S+PS)/
8396      &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8397         ENDIF
8398       ENDIF
8399       IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8400
8401 C...Format statements for differential cross-section maximum violations.
8402  5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8403      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8404  5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8405      &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8406  5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8407      &'in event',1X,I7)
8408  5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8409      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8410  5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8411      &'in event',1X,I7)
8412  5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8413  5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8414  5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8415  5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8416  5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8417  6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8418
8419       RETURN
8420       END
8421
8422 C*********************************************************************
8423
8424 C...PYSCAT
8425 C...Finds outgoing flavours and event type; sets up the kinematics
8426 C...and colour flow of the hard scattering
8427
8428       SUBROUTINE PYSCAT
8429
8430 C...Double precision and integer declarations
8431       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8432       IMPLICIT INTEGER(I-N)
8433       INTEGER PYK,PYCHGE,PYCOMP
8434 C...Parameter statement to help give large particle numbers.
8435       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8436      &KEXCIT=4000000,KDIMEN=5000000)
8437
8438 C...User process event common block.
8439       INTEGER MAXNUP
8440       PARAMETER (MAXNUP=500)
8441       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8442       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8443       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8444      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8445      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8446       SAVE /HEPEUP/
8447
8448 C...Commonblocks
8449       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8450       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8451       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8452       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8453       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8454       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8455       COMMON/PYINT1/MINT(400),VINT(400)
8456       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8457       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8458       COMMON/PYINT4/MWID(500),WIDS(500,5)
8459       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8460       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8461      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8462       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8463      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/
8464 C...Local arrays and saved variables
8465       DIMENSION WDTP(0:300),WDTE(0:300,0:5),PMQ(2),Z(2),CTHE(2),
8466      &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8467       SAVE VINTSV
8468
8469 C...Read out process
8470       ISUB=MINT(1)
8471       ISUBSV=ISUB
8472
8473 C...Restore information for low-pT processes
8474       IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8475         DO 100 J=41,66
8476   100   VINT(J)=VINTSV(J)
8477       ENDIF
8478
8479 C...Convert H' or A process into equivalent H one
8480       IHIGG=1
8481       KFHIGG=25
8482       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8483      &ISUB.LE.190)) THEN
8484         IHIGG=2
8485         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8486         KFHIGG=33+IHIGG
8487         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8488         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8489         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8490         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8491         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8492         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8493         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8494         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8495         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8496         IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8497         IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8498         IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8499       ENDIF
8500
8501 C...Choice of subprocess, number of documentation lines
8502       IDOC=6+ISET(ISUB)
8503       IF(ISUB.EQ.95) IDOC=8
8504       IF(ISET(ISUB).EQ.5) IDOC=9
8505       IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8506       MINT(3)=IDOC-6
8507       IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8508       MINT(4)=IDOC
8509       IPU1=MINT(84)+1
8510       IPU2=MINT(84)+2
8511       IPU3=MINT(84)+3
8512       IPU4=MINT(84)+4
8513       IPU5=MINT(84)+5
8514       IPU6=MINT(84)+6
8515
8516 C...Reset K, P and V vectors. Store incoming particles
8517       DO 120 JT=1,MSTP(126)+100
8518         I=MINT(83)+JT
8519         IF(I.GT.MSTU(4)) GOTO 120
8520         DO 110 J=1,5
8521           K(I,J)=0
8522           P(I,J)=0D0
8523           V(I,J)=0D0
8524   110   CONTINUE
8525   120 CONTINUE
8526       DO 140 JT=1,2
8527         I=MINT(83)+JT
8528         K(I,1)=21
8529         K(I,2)=MINT(10+JT)
8530         DO 130 J=1,5
8531           P(I,J)=VINT(285+5*JT+J)
8532   130   CONTINUE
8533   140 CONTINUE
8534       MINT(6)=2
8535       KFRES=0
8536
8537 C...Store incoming partons in their CM-frame
8538       SH=VINT(44)
8539       SHR=SQRT(SH)
8540       SHP=VINT(26)*VINT(2)
8541       SHPR=SQRT(SHP)
8542       SHUSER=SHR
8543       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8544       DO 150 JT=1,2
8545         I=MINT(84)+JT
8546         K(I,1)=14
8547         K(I,2)=MINT(14+JT)
8548         K(I,3)=MINT(83)+2+JT
8549         P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8550         P(I,4)=0.5D0*SHUSER
8551   150 CONTINUE
8552
8553 C...Copy incoming partons to documentation lines
8554       DO 170 JT=1,2
8555         I1=MINT(83)+4+JT
8556         I2=MINT(84)+JT
8557         K(I1,1)=21
8558         K(I1,2)=K(I2,2)
8559         K(I1,3)=I1-2
8560         DO 160 J=1,5
8561           P(I1,J)=P(I2,J)
8562   160   CONTINUE
8563   170 CONTINUE
8564
8565 C...Choose new quark/lepton flavour for relevant annihilation graphs
8566       IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8567      &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
8568         IGLGA=21
8569         IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8570         CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8571   180   RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8572         DO 190 I=1,MDCY(IGLGA,3)
8573           KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8574           RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8575           IF(RKFL.LE.0D0) GOTO 200
8576   190   CONTINUE
8577   200   CONTINUE
8578         IF(ISUB.EQ.53.AND.MINT(2).LE.2) THEN
8579           IF(KFLF.GE.4) GOTO 180
8580         ELSEIF(ISUB.EQ.53.AND.MINT(2).LE.4) THEN
8581           KFLF=4
8582           MINT(2)=MINT(2)-2
8583         ELSEIF(ISUB.EQ.53) THEN
8584           KFLF=5
8585           MINT(2)=MINT(2)-4
8586         ELSEIF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
8587      &  IABS(KFLF).GE.3) THEN
8588           FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8589      &    VINT(44)**2
8590           FACCIB=VINT(46)**2/PARU(155)**4
8591           IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8592         ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8593           IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8594         ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8595           IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8596         ENDIF
8597       ENDIF
8598
8599 C...Final state flavours and colour flow: default values
8600       JS=1
8601       MINT(21)=MINT(15)
8602       MINT(22)=MINT(16)
8603       MINT(23)=0
8604       MINT(24)=0
8605       KCC=20
8606       KCS=ISIGN(1,MINT(15))
8607
8608       IF(ISET(ISUB).EQ.11) THEN
8609 C...User-defined processes: find products
8610         MINT(3)=0
8611         DO 210 IUP=3,NUP
8612           IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8613           ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8614             MINT(21+IUP)=IDUP(IUP)
8615           ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8616      &    ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8617           ELSEIF(IDUP(IUP).EQ.0) THEN
8618           ELSE
8619             MINT(3)=MINT(3)+1
8620             IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8621           ENDIF
8622   210   CONTINUE
8623
8624       ELSEIF(ISUB.LE.10) THEN
8625         IF(ISUB.EQ.1) THEN
8626 C...f + fbar -> gamma*/Z0
8627           KFRES=23
8628
8629         ELSEIF(ISUB.EQ.2) THEN
8630 C...f + fbar' -> W+/-
8631           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8632           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8633           KFRES=ISIGN(24,KCH1+KCH2)
8634
8635         ELSEIF(ISUB.EQ.3) THEN
8636 C...f + fbar -> h0 (or H0, or A0)
8637           KFRES=KFHIGG
8638
8639         ELSEIF(ISUB.EQ.4) THEN
8640 C...gamma + W+/- -> W+/-
8641
8642         ELSEIF(ISUB.EQ.5) THEN
8643 C...Z0 + Z0 -> h0
8644           XH=SH/SHP
8645           MINT(21)=MINT(15)
8646           MINT(22)=MINT(16)
8647           PMQ(1)=PYMASS(MINT(21))
8648           PMQ(2)=PYMASS(MINT(22))
8649   220     JT=INT(1.5D0+PYR(0))
8650           ZMIN=2D0*PMQ(JT)/SHPR
8651           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8652      &    (SHPR*(SHPR-PMQ(3-JT)))
8653           ZMAX=MIN(1D0-XH,ZMAX)
8654           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8655           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8656      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8657           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8658           IF(SQC1.LT.1D-8) GOTO 220
8659           C1=SQRT(SQC1)
8660           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8661           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8662           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8663           Z(3-JT)=1D0-XH/(1D0-Z(JT))
8664           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8665           IF(SQC1.LT.1D-8) GOTO 220
8666           C1=SQRT(SQC1)
8667           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8668           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8669           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8670           PHIR=PARU(2)*PYR(0)
8671           CPHI=COS(PHIR)
8672           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8673      &    SQRT(1D0-CTHE(2)**2)*CPHI
8674           Z1=2D0-Z(JT)
8675           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8676           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8677           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8678      &    PMQ(3-JT)**2/SHP))
8679           ZMIN=2D0*PMQ(3-JT)/SHPR
8680           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8681           ZMAX=MIN(1D0-XH,ZMAX)
8682           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8683           KCC=22
8684           KFRES=25
8685
8686         ELSEIF(ISUB.EQ.6) THEN
8687 C...Z0 + W+/- -> W+/-
8688
8689         ELSEIF(ISUB.EQ.7) THEN
8690 C...W+ + W- -> Z0
8691
8692         ELSEIF(ISUB.EQ.8) THEN
8693 C...W+ + W- -> h0
8694           XH=SH/SHP
8695   230     DO 260 JT=1,2
8696             I=MINT(14+JT)
8697             IA=IABS(I)
8698             IF(IA.LE.10) THEN
8699               RVCKM=VINT(180+I)*PYR(0)
8700               DO 240 J=1,MSTP(1)
8701                 IB=2*J-1+MOD(IA,2)
8702                 IPM=(5-ISIGN(1,I))/2
8703                 IDC=J+MDCY(IA,2)+2
8704                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8705                 MINT(20+JT)=ISIGN(IB,I)
8706                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8707                 IF(RVCKM.LE.0D0) GOTO 250
8708   240         CONTINUE
8709             ELSE
8710               IB=2*((IA+1)/2)-1+MOD(IA,2)
8711               MINT(20+JT)=ISIGN(IB,I)
8712             ENDIF
8713   250       PMQ(JT)=PYMASS(MINT(20+JT))
8714   260     CONTINUE
8715           JT=INT(1.5D0+PYR(0))
8716           ZMIN=2D0*PMQ(JT)/SHPR
8717           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8718      &    (SHPR*(SHPR-PMQ(3-JT)))
8719           ZMAX=MIN(1D0-XH,ZMAX)
8720           IF(ZMIN.GE.ZMAX) GOTO 230
8721           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8722           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8723      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8724           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8725           IF(SQC1.LT.1D-8) GOTO 230
8726           C1=SQRT(SQC1)
8727           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8728           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8729           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8730           Z(3-JT)=1D0-XH/(1D0-Z(JT))
8731           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8732           IF(SQC1.LT.1D-8) GOTO 230
8733           C1=SQRT(SQC1)
8734           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8735           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8736           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8737           PHIR=PARU(2)*PYR(0)
8738           CPHI=COS(PHIR)
8739           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8740      &    SQRT(1D0-CTHE(2)**2)*CPHI
8741           Z1=2D0-Z(JT)
8742           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8743           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8744           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8745      &    PMQ(3-JT)**2/SHP))
8746           ZMIN=2D0*PMQ(3-JT)/SHPR
8747           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8748           ZMAX=MIN(1D0-XH,ZMAX)
8749           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8750           KCC=22
8751           KFRES=25
8752
8753         ELSEIF(ISUB.EQ.10) THEN
8754 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8755           IF(MINT(2).EQ.1) THEN
8756             KCC=22
8757           ELSE
8758 C...W exchange: need to mix flavours according to CKM matrix
8759             DO 280 JT=1,2
8760               I=MINT(14+JT)
8761               IA=IABS(I)
8762               IF(IA.LE.10) THEN
8763                 RVCKM=VINT(180+I)*PYR(0)
8764                 DO 270 J=1,MSTP(1)
8765                   IB=2*J-1+MOD(IA,2)
8766                   IPM=(5-ISIGN(1,I))/2
8767                   IDC=J+MDCY(IA,2)+2
8768                   IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8769                   MINT(20+JT)=ISIGN(IB,I)
8770                   RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8771                   IF(RVCKM.LE.0D0) GOTO 280
8772   270           CONTINUE
8773               ELSE
8774                 IB=2*((IA+1)/2)-1+MOD(IA,2)
8775                 MINT(20+JT)=ISIGN(IB,I)
8776               ENDIF
8777   280       CONTINUE
8778             KCC=22
8779           ENDIF
8780         ENDIF
8781
8782       ELSEIF(ISUB.LE.20) THEN
8783         IF(ISUB.EQ.11) THEN
8784 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8785           KCC=MINT(2)
8786           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8787
8788         ELSEIF(ISUB.EQ.12) THEN
8789 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8790           MINT(21)=ISIGN(KFLF,MINT(15))
8791           MINT(22)=-MINT(21)
8792           KCC=4
8793
8794         ELSEIF(ISUB.EQ.13) THEN
8795 C...f + fbar -> g + g; th arbitrary
8796           MINT(21)=21
8797           MINT(22)=21
8798           KCC=MINT(2)+4
8799
8800         ELSEIF(ISUB.EQ.14) THEN
8801 C...f + fbar -> g + gamma; th arbitrary
8802           IF(PYR(0).GT.0.5D0) JS=2
8803           MINT(20+JS)=21
8804           MINT(23-JS)=22
8805           KCC=17+JS
8806
8807         ELSEIF(ISUB.EQ.15) THEN
8808 C...f + fbar -> g + Z0; th arbitrary
8809           IF(PYR(0).GT.0.5D0) JS=2
8810           MINT(20+JS)=21
8811           MINT(23-JS)=23
8812           KCC=17+JS
8813
8814         ELSEIF(ISUB.EQ.16) THEN
8815 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8816           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8817           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8818           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8819           MINT(20+JS)=21
8820           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8821           KCC=17+JS
8822
8823         ELSEIF(ISUB.EQ.17) THEN
8824 C...f + fbar -> g + h0; th arbitrary
8825           IF(PYR(0).GT.0.5D0) JS=2
8826           MINT(20+JS)=21
8827           MINT(23-JS)=25
8828           KCC=17+JS
8829
8830         ELSEIF(ISUB.EQ.18) THEN
8831 C...f + fbar -> gamma + gamma; th arbitrary
8832           MINT(21)=22
8833           MINT(22)=22
8834
8835         ELSEIF(ISUB.EQ.19) THEN
8836 C...f + fbar -> gamma + Z0; th arbitrary
8837           IF(PYR(0).GT.0.5D0) JS=2
8838           MINT(20+JS)=22
8839           MINT(23-JS)=23
8840
8841         ELSEIF(ISUB.EQ.20) THEN
8842 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8843 C...(p(fbar')-p(W+))**2
8844           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8845           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8846           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8847           MINT(20+JS)=22
8848           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8849         ENDIF
8850
8851       ELSEIF(ISUB.LE.30) THEN
8852         IF(ISUB.EQ.21) THEN
8853 C...f + fbar -> gamma + h0; th arbitrary
8854           IF(PYR(0).GT.0.5D0) JS=2
8855           MINT(20+JS)=22
8856           MINT(23-JS)=25
8857
8858         ELSEIF(ISUB.EQ.22) THEN
8859 C...f + fbar -> Z0 + Z0; th arbitrary
8860           MINT(21)=23
8861           MINT(22)=23
8862
8863         ELSEIF(ISUB.EQ.23) THEN
8864 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8865           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8866           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8867           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8868           MINT(20+JS)=23
8869           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8870
8871         ELSEIF(ISUB.EQ.24) THEN
8872 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8873           IF(PYR(0).GT.0.5D0) JS=2
8874           MINT(20+JS)=23
8875           MINT(23-JS)=KFHIGG
8876
8877         ELSEIF(ISUB.EQ.25) THEN
8878 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8879           MINT(21)=-ISIGN(24,MINT(15))
8880           MINT(22)=-MINT(21)
8881
8882         ELSEIF(ISUB.EQ.26) THEN
8883 C...f + fbar' -> W+/- + h0 (or H0, or A0);
8884 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8885           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8886           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8887           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8888           MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8889           MINT(23-JS)=KFHIGG
8890
8891         ELSEIF(ISUB.EQ.27) THEN
8892 C...f + fbar -> h0 + h0
8893
8894         ELSEIF(ISUB.EQ.28) THEN
8895 C...f + g -> f + g; th = (p(f)-p(f))**2
8896           KCC=MINT(2)+6
8897           IF(MINT(15).EQ.21) KCC=KCC+2
8898           IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8899           IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8900
8901         ELSEIF(ISUB.EQ.29) THEN
8902 C...f + g -> f + gamma; th = (p(f)-p(f))**2
8903           IF(MINT(15).EQ.21) JS=2
8904           MINT(23-JS)=22
8905           KCC=15+JS
8906           KCS=ISIGN(1,MINT(14+JS))
8907
8908         ELSEIF(ISUB.EQ.30) THEN
8909 C...f + g -> f + Z0; th = (p(f)-p(f))**2
8910           IF(MINT(15).EQ.21) JS=2
8911           MINT(23-JS)=23
8912           KCC=15+JS
8913           KCS=ISIGN(1,MINT(14+JS))
8914         ENDIF
8915
8916       ELSEIF(ISUB.LE.40) THEN
8917         IF(ISUB.EQ.31) THEN
8918 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8919           IF(MINT(15).EQ.21) JS=2
8920           I=MINT(14+JS)
8921           IA=IABS(I)
8922           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8923           RVCKM=VINT(180+I)*PYR(0)
8924           DO 290 J=1,MSTP(1)
8925             IB=2*J-1+MOD(IA,2)
8926             IPM=(5-ISIGN(1,I))/2
8927             IDC=J+MDCY(IA,2)+2
8928             IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
8929             MINT(20+JS)=ISIGN(IB,I)
8930             RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8931             IF(RVCKM.LE.0D0) GOTO 300
8932   290     CONTINUE
8933   300     KCC=15+JS
8934           KCS=ISIGN(1,MINT(14+JS))
8935
8936         ELSEIF(ISUB.EQ.32) THEN
8937 C...f + g -> f + h0; th = (p(f)-p(f))**2
8938           IF(MINT(15).EQ.21) JS=2
8939           MINT(23-JS)=25
8940           KCC=15+JS
8941           KCS=ISIGN(1,MINT(14+JS))
8942
8943         ELSEIF(ISUB.EQ.33) THEN
8944 C...f + gamma -> f + g; th=(p(f)-p(f))**2
8945           IF(MINT(15).EQ.22) JS=2
8946           MINT(23-JS)=21
8947           KCC=24+JS
8948           KCS=ISIGN(1,MINT(14+JS))
8949
8950         ELSEIF(ISUB.EQ.34) THEN
8951 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8952           IF(MINT(15).EQ.22) JS=2
8953           KCC=22
8954           KCS=ISIGN(1,MINT(14+JS))
8955
8956         ELSEIF(ISUB.EQ.35) THEN
8957 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8958           IF(MINT(15).EQ.22) JS=2
8959           MINT(23-JS)=23
8960           KCC=22
8961
8962         ELSEIF(ISUB.EQ.36) THEN
8963 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8964           IF(MINT(15).EQ.22) JS=2
8965           I=MINT(14+JS)
8966           IA=IABS(I)
8967           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8968           IF(IA.LE.10) THEN
8969             RVCKM=VINT(180+I)*PYR(0)
8970             DO 310 J=1,MSTP(1)
8971               IB=2*J-1+MOD(IA,2)
8972               IPM=(5-ISIGN(1,I))/2
8973               IDC=J+MDCY(IA,2)+2
8974               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
8975               MINT(20+JS)=ISIGN(IB,I)
8976               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8977               IF(RVCKM.LE.0D0) GOTO 320
8978   310       CONTINUE
8979           ELSE
8980             IB=2*((IA+1)/2)-1+MOD(IA,2)
8981             MINT(20+JS)=ISIGN(IB,I)
8982           ENDIF
8983   320     KCC=22
8984
8985         ELSEIF(ISUB.EQ.37) THEN
8986 C...f + gamma -> f + h0
8987
8988         ELSEIF(ISUB.EQ.38) THEN
8989 C...f + Z0 -> f + g
8990
8991         ELSEIF(ISUB.EQ.39) THEN
8992 C...f + Z0 -> f + gamma
8993
8994         ELSEIF(ISUB.EQ.40) THEN
8995 C...f + Z0 -> f + Z0
8996         ENDIF
8997
8998       ELSEIF(ISUB.LE.50) THEN
8999         IF(ISUB.EQ.41) THEN
9000 C...f + Z0 -> f' + W+/-
9001
9002         ELSEIF(ISUB.EQ.42) THEN
9003 C...f + Z0 -> f + h0
9004
9005         ELSEIF(ISUB.EQ.43) THEN
9006 C...f + W+/- -> f' + g
9007
9008         ELSEIF(ISUB.EQ.44) THEN
9009 C...f + W+/- -> f' + gamma
9010
9011         ELSEIF(ISUB.EQ.45) THEN
9012 C...f + W+/- -> f' + Z0
9013
9014         ELSEIF(ISUB.EQ.46) THEN
9015 C...f + W+/- -> f' + W+/-
9016
9017         ELSEIF(ISUB.EQ.47) THEN
9018 C...f + W+/- -> f' + h0
9019
9020         ELSEIF(ISUB.EQ.48) THEN
9021 C...f + h0 -> f + g
9022
9023         ELSEIF(ISUB.EQ.49) THEN
9024 C...f + h0 -> f + gamma
9025
9026         ELSEIF(ISUB.EQ.50) THEN
9027 C...f + h0 -> f + Z0
9028         ENDIF
9029
9030       ELSEIF(ISUB.LE.60) THEN
9031         IF(ISUB.EQ.51) THEN
9032 C...f + h0 -> f' + W+/-
9033
9034         ELSEIF(ISUB.EQ.52) THEN
9035 C...f + h0 -> f + h0
9036
9037         ELSEIF(ISUB.EQ.53) THEN
9038 C...g + g -> f + fbar; th arbitrary
9039           KCS=(-1)**INT(1.5D0+PYR(0))
9040           MINT(21)=ISIGN(KFLF,KCS)
9041           MINT(22)=-MINT(21)
9042           KCC=MINT(2)+10
9043
9044         ELSEIF(ISUB.EQ.54) THEN
9045 C...g + gamma -> f + fbar; th arbitrary
9046           KCS=(-1)**INT(1.5D0+PYR(0))
9047           MINT(21)=ISIGN(KFLF,KCS)
9048           MINT(22)=-MINT(21)
9049           KCC=27
9050           IF(MINT(16).EQ.21) KCC=28
9051
9052         ELSEIF(ISUB.EQ.55) THEN
9053 C...g + Z0 -> f + fbar
9054
9055         ELSEIF(ISUB.EQ.56) THEN
9056 C...g + W+/- -> f + fbar'
9057
9058         ELSEIF(ISUB.EQ.57) THEN
9059 C...g + h0 -> f + fbar
9060
9061         ELSEIF(ISUB.EQ.58) THEN
9062 C...gamma + gamma -> f + fbar; th arbitrary
9063           KCS=(-1)**INT(1.5D0+PYR(0))
9064           MINT(21)=ISIGN(KFLF,KCS)
9065           MINT(22)=-MINT(21)
9066           KCC=21
9067
9068         ELSEIF(ISUB.EQ.59) THEN
9069 C...gamma + Z0 -> f + fbar
9070
9071         ELSEIF(ISUB.EQ.60) THEN
9072 C...gamma + W+/- -> f + fbar'
9073         ENDIF
9074
9075       ELSEIF(ISUB.LE.70) THEN
9076         IF(ISUB.EQ.61) THEN
9077 C...gamma + h0 -> f + fbar
9078
9079         ELSEIF(ISUB.EQ.62) THEN
9080 C...Z0 + Z0 -> f + fbar
9081
9082         ELSEIF(ISUB.EQ.63) THEN
9083 C...Z0 + W+/- -> f + fbar'
9084
9085         ELSEIF(ISUB.EQ.64) THEN
9086 C...Z0 + h0 -> f + fbar
9087
9088         ELSEIF(ISUB.EQ.65) THEN
9089 C...W+ + W- -> f + fbar
9090
9091         ELSEIF(ISUB.EQ.66) THEN
9092 C...W+/- + h0 -> f + fbar'
9093
9094         ELSEIF(ISUB.EQ.67) THEN
9095 C...h0 + h0 -> f + fbar
9096
9097         ELSEIF(ISUB.EQ.68) THEN
9098 C...g + g -> g + g; th arbitrary
9099           KCC=MINT(2)+12
9100           KCS=(-1)**INT(1.5D0+PYR(0))
9101
9102         ELSEIF(ISUB.EQ.69) THEN
9103 C...gamma + gamma -> W+ + W-; th arbitrary
9104           MINT(21)=24
9105           MINT(22)=-24
9106           KCC=21
9107
9108         ELSEIF(ISUB.EQ.70) THEN
9109 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9110           IF(MINT(15).EQ.22) MINT(21)=23
9111           IF(MINT(16).EQ.22) MINT(22)=23
9112           KCC=21
9113         ENDIF
9114
9115       ELSEIF(ISUB.LE.80) THEN
9116         IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9117 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9118           XH=SH/SHP
9119           MINT(21)=MINT(15)
9120           MINT(22)=MINT(16)
9121           PMQ(1)=PYMASS(MINT(21))
9122           PMQ(2)=PYMASS(MINT(22))
9123   330     JT=INT(1.5D0+PYR(0))
9124           ZMIN=2D0*PMQ(JT)/SHPR
9125           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9126      &    (SHPR*(SHPR-PMQ(3-JT)))
9127           ZMAX=MIN(1D0-XH,ZMAX)
9128           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9129           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9130      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9131           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9132           IF(SQC1.LT.1D-8) GOTO 330
9133           C1=SQRT(SQC1)
9134           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9135           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9136           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9137           Z(3-JT)=1D0-XH/(1D0-Z(JT))
9138           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9139           IF(SQC1.LT.1D-8) GOTO 330
9140           C1=SQRT(SQC1)
9141           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9142           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9143           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9144           PHIR=PARU(2)*PYR(0)
9145           CPHI=COS(PHIR)
9146           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9147      &    SQRT(1D0-CTHE(2)**2)*CPHI
9148           Z1=2D0-Z(JT)
9149           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9150           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9151           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9152      &    PMQ(3-JT)**2/SHP))
9153           ZMIN=2D0*PMQ(3-JT)/SHPR
9154           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9155           ZMAX=MIN(1D0-XH,ZMAX)
9156           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9157           KCC=22
9158
9159         ELSEIF(ISUB.EQ.73) THEN
9160 C...Z0 + W+/- -> Z0 + W+/-
9161           JS=MINT(2)
9162           XH=SH/SHP
9163   340     JT=3-MINT(2)
9164           I=MINT(14+JT)
9165           IA=IABS(I)
9166           IF(IA.LE.10) THEN
9167             RVCKM=VINT(180+I)*PYR(0)
9168             DO 350 J=1,MSTP(1)
9169               IB=2*J-1+MOD(IA,2)
9170               IPM=(5-ISIGN(1,I))/2
9171               IDC=J+MDCY(IA,2)+2
9172               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9173               MINT(20+JT)=ISIGN(IB,I)
9174               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9175               IF(RVCKM.LE.0D0) GOTO 360
9176   350       CONTINUE
9177           ELSE
9178             IB=2*((IA+1)/2)-1+MOD(IA,2)
9179             MINT(20+JT)=ISIGN(IB,I)
9180           ENDIF
9181   360     PMQ(JT)=PYMASS(MINT(20+JT))
9182           MINT(23-JT)=MINT(17-JT)
9183           PMQ(3-JT)=PYMASS(MINT(23-JT))
9184           JT=INT(1.5D0+PYR(0))
9185           ZMIN=2D0*PMQ(JT)/SHPR
9186           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9187      &    (SHPR*(SHPR-PMQ(3-JT)))
9188           ZMAX=MIN(1D0-XH,ZMAX)
9189           IF(ZMIN.GE.ZMAX) GOTO 340
9190           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9191           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9192      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9193           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9194           IF(SQC1.LT.1D-8) GOTO 340
9195           C1=SQRT(SQC1)
9196           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9197           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9198           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9199           Z(3-JT)=1D0-XH/(1D0-Z(JT))
9200           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9201           IF(SQC1.LT.1D-8) GOTO 340
9202           C1=SQRT(SQC1)
9203           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9204           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9205           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9206           PHIR=PARU(2)*PYR(0)
9207           CPHI=COS(PHIR)
9208           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9209      &    SQRT(1D0-CTHE(2)**2)*CPHI
9210           Z1=2D0-Z(JT)
9211           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9212           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9213           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9214      &    PMQ(3-JT)**2/SHP))
9215           ZMIN=2D0*PMQ(3-JT)/SHPR
9216           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9217           ZMAX=MIN(1D0-XH,ZMAX)
9218           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9219           KCC=22
9220
9221         ELSEIF(ISUB.EQ.74) THEN
9222 C...Z0 + h0 -> Z0 + h0
9223
9224         ELSEIF(ISUB.EQ.75) THEN
9225 C...W+ + W- -> gamma + gamma
9226
9227         ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9228 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9229           XH=SH/SHP
9230   370     DO 400 JT=1,2
9231             I=MINT(14+JT)
9232             IA=IABS(I)
9233             IF(IA.LE.10) THEN
9234               RVCKM=VINT(180+I)*PYR(0)
9235               DO 380 J=1,MSTP(1)
9236                 IB=2*J-1+MOD(IA,2)
9237                 IPM=(5-ISIGN(1,I))/2
9238                 IDC=J+MDCY(IA,2)+2
9239                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9240                 MINT(20+JT)=ISIGN(IB,I)
9241                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9242                 IF(RVCKM.LE.0D0) GOTO 390
9243   380         CONTINUE
9244             ELSE
9245               IB=2*((IA+1)/2)-1+MOD(IA,2)
9246               MINT(20+JT)=ISIGN(IB,I)
9247             ENDIF
9248   390       PMQ(JT)=PYMASS(MINT(20+JT))
9249   400     CONTINUE
9250           JT=INT(1.5D0+PYR(0))
9251           ZMIN=2D0*PMQ(JT)/SHPR
9252           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9253      &    (SHPR*(SHPR-PMQ(3-JT)))
9254           ZMAX=MIN(1D0-XH,ZMAX)
9255           IF(ZMIN.GE.ZMAX) GOTO 370
9256           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9257           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9258      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9259           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9260           IF(SQC1.LT.1D-8) GOTO 370
9261           C1=SQRT(SQC1)
9262           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9263           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9264           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9265           Z(3-JT)=1D0-XH/(1D0-Z(JT))
9266           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9267           IF(SQC1.LT.1D-8) GOTO 370
9268           C1=SQRT(SQC1)
9269           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9270           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9271           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9272           PHIR=PARU(2)*PYR(0)
9273           CPHI=COS(PHIR)
9274           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9275      &    SQRT(1D0-CTHE(2)**2)*CPHI
9276           Z1=2D0-Z(JT)
9277           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9278           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9279           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9280      &    PMQ(3-JT)**2/SHP))
9281           ZMIN=2D0*PMQ(3-JT)/SHPR
9282           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9283           ZMAX=MIN(1D0-XH,ZMAX)
9284           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9285           KCC=22
9286
9287         ELSEIF(ISUB.EQ.78) THEN
9288 C...W+/- + h0 -> W+/- + h0
9289
9290         ELSEIF(ISUB.EQ.79) THEN
9291 C...h0 + h0 -> h0 + h0
9292
9293         ELSEIF(ISUB.EQ.80) THEN
9294 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9295           IF(MINT(15).EQ.22) JS=2
9296           I=MINT(14+JS)
9297           IA=IABS(I)
9298           MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9299           IB=3-IA
9300           MINT(20+JS)=ISIGN(IB,I)
9301           KCC=22
9302         ENDIF
9303
9304       ELSEIF(ISUB.LE.90) THEN
9305         IF(ISUB.EQ.81) THEN
9306 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9307           MINT(21)=ISIGN(MINT(55),MINT(15))
9308           MINT(22)=-MINT(21)
9309           KCC=4
9310
9311         ELSEIF(ISUB.EQ.82) THEN
9312 C...g + g -> Q + Qbar; th arbitrary
9313           KCS=(-1)**INT(1.5D0+PYR(0))
9314           MINT(21)=ISIGN(MINT(55),KCS)
9315           MINT(22)=-MINT(21)
9316           KCC=MINT(2)+10
9317
9318         ELSEIF(ISUB.EQ.83) THEN
9319 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9320           KFOLD=MINT(16)
9321           IF(MINT(2).EQ.2) KFOLD=MINT(15)
9322           KFAOLD=IABS(KFOLD)
9323           IF(KFAOLD.GT.10) THEN
9324             KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9325           ELSE
9326             RCKM=VINT(180+KFOLD)*PYR(0)
9327             IPM=(5-ISIGN(1,KFOLD))/2
9328             KFANEW=-MOD(KFAOLD+1,2)
9329   410       KFANEW=KFANEW+2
9330             IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9331             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9332               IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9333      &        VCKM(KFAOLD/2,(KFANEW+1)/2)
9334               IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9335      &        VCKM(KFANEW/2,(KFAOLD+1)/2)
9336             ENDIF
9337             IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9338           ENDIF
9339           IF(MINT(2).EQ.1) THEN
9340             MINT(21)=ISIGN(MINT(55),MINT(15))
9341             MINT(22)=ISIGN(KFANEW,MINT(16))
9342           ELSE
9343             MINT(21)=ISIGN(KFANEW,MINT(15))
9344             MINT(22)=ISIGN(MINT(55),MINT(16))
9345             JS=2
9346           ENDIF
9347           KCC=22
9348
9349         ELSEIF(ISUB.EQ.84) THEN
9350 C...g + gamma -> Q + Qbar; th arbitary
9351           KCS=(-1)**INT(1.5D0+PYR(0))
9352           MINT(21)=ISIGN(MINT(55),KCS)
9353           MINT(22)=-MINT(21)
9354           KCC=27
9355           IF(MINT(16).EQ.21) KCC=28
9356
9357         ELSEIF(ISUB.EQ.85) THEN
9358 C...gamma + gamma -> F + Fbar; th arbitary
9359           KCS=(-1)**INT(1.5D0+PYR(0))
9360           MINT(21)=ISIGN(MINT(56),KCS)
9361           MINT(22)=-MINT(21)
9362           KCC=21
9363
9364         ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9365 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9366           MINT(21)=KFPR(ISUB,1)
9367           MINT(22)=KFPR(ISUB,2)
9368           KCC=24
9369           KCS=(-1)**INT(1.5D0+PYR(0))
9370         ENDIF
9371
9372       ELSEIF(ISUB.LE.100) THEN
9373         IF(ISUB.EQ.95) THEN
9374 C...Low-pT ( = energyless g + g -> g + g)
9375           KCC=MINT(2)+12
9376           KCS=(-1)**INT(1.5D0+PYR(0))
9377
9378         ELSEIF(ISUB.EQ.96) THEN
9379 C...Multiple interactions (should be reassigned to QCD process)
9380         ENDIF
9381
9382       ELSEIF(ISUB.LE.110) THEN
9383         IF(ISUB.EQ.101) THEN
9384 C...g + g -> gamma*/Z0
9385           KCC=21
9386           KFRES=22
9387
9388         ELSEIF(ISUB.EQ.102) THEN
9389 C...g + g -> h0 (or H0, or A0)
9390           KCC=21
9391           KFRES=KFHIGG
9392
9393         ELSEIF(ISUB.EQ.103) THEN
9394 C...gamma + gamma -> h0 (or H0, or A0)
9395           KCC=21
9396           KFRES=KFHIGG
9397
9398         ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9399 C...g + g -> chi_0c or chi_2c.
9400           KCC=21
9401           KFRES=KFPR(ISUB,1)
9402
9403         ELSEIF(ISUB.EQ.106) THEN
9404 C...g + g -> J/Psi + gamma
9405           MINT(21)=KFPR(ISUB,1)
9406           MINT(22)=KFPR(ISUB,2)
9407           KCC=21
9408
9409         ELSEIF(ISUB.EQ.107) THEN
9410 C...g + gamma -> J/Psi + g
9411           MINT(21)=KFPR(ISUB,1)
9412           MINT(22)=KFPR(ISUB,2)
9413           KCC=22
9414           IF(MINT(16).EQ.22) KCC=33
9415
9416         ELSEIF(ISUB.EQ.108) THEN
9417 C...gamma + gamma -> J/Psi + gamma
9418           MINT(21)=KFPR(ISUB,1)
9419           MINT(22)=KFPR(ISUB,2)
9420
9421         ELSEIF(ISUB.EQ.110) THEN
9422 C...f + fbar -> gamma + h0; th arbitrary
9423           IF(PYR(0).GT.0.5D0) JS=2
9424           MINT(20+JS)=22
9425           MINT(23-JS)=KFHIGG
9426         ENDIF
9427
9428       ELSEIF(ISUB.LE.120) THEN
9429         IF(ISUB.EQ.111) THEN
9430 C...f + fbar -> g + h0; th arbitrary
9431           IF(PYR(0).GT.0.5D0) JS=2
9432           MINT(20+JS)=21
9433           MINT(23-JS)=KFHIGG
9434           KCC=17+JS
9435
9436         ELSEIF(ISUB.EQ.112) THEN
9437 C...f + g -> f + h0; th = (p(f) - p(f))**2
9438           IF(MINT(15).EQ.21) JS=2
9439           MINT(23-JS)=KFHIGG
9440           KCC=15+JS
9441           KCS=ISIGN(1,MINT(14+JS))
9442
9443         ELSEIF(ISUB.EQ.113) THEN
9444 C...g + g -> g + h0; th arbitrary
9445           IF(PYR(0).GT.0.5D0) JS=2
9446           MINT(23-JS)=KFHIGG
9447           KCC=22+JS
9448           KCS=(-1)**INT(1.5D0+PYR(0))
9449
9450         ELSEIF(ISUB.EQ.114) THEN
9451 C...g + g -> gamma + gamma; th arbitrary
9452           IF(PYR(0).GT.0.5D0) JS=2
9453           MINT(21)=22
9454           MINT(22)=22
9455           KCC=21
9456
9457         ELSEIF(ISUB.EQ.115) THEN
9458 C...g + g -> g + gamma; th arbitrary
9459           IF(PYR(0).GT.0.5D0) JS=2
9460           MINT(23-JS)=22
9461           KCC=22+JS
9462           KCS=(-1)**INT(1.5D0+PYR(0))
9463
9464         ELSEIF(ISUB.EQ.116) THEN
9465 C...g + g -> gamma + Z0
9466
9467         ELSEIF(ISUB.EQ.117) THEN
9468 C...g + g -> Z0 + Z0
9469
9470         ELSEIF(ISUB.EQ.118) THEN
9471 C...g + g -> W+ + W-
9472         ENDIF
9473
9474       ELSEIF(ISUB.LE.140) THEN
9475         IF(ISUB.EQ.121) THEN
9476 C...g + g -> Q + Qbar + h0
9477           KCS=(-1)**INT(1.5D0+PYR(0))
9478           MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9479           MINT(22)=-MINT(21)
9480           KCC=11+INT(0.5D0+PYR(0))
9481           KFRES=KFHIGG
9482
9483         ELSEIF(ISUB.EQ.122) THEN
9484 C...q + qbar -> Q + Qbar + h0
9485           MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9486           MINT(22)=-MINT(21)
9487           KCC=4
9488           KFRES=KFHIGG
9489
9490         ELSEIF(ISUB.EQ.123) THEN
9491 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9492 C...inner process)
9493           KCC=22
9494           KFRES=KFHIGG
9495
9496         ELSEIF(ISUB.EQ.124) THEN
9497 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9498 C...inner process)
9499           DO 430 JT=1,2
9500             I=MINT(14+JT)
9501             IA=IABS(I)
9502             IF(IA.LE.10) THEN
9503               RVCKM=VINT(180+I)*PYR(0)
9504               DO 420 J=1,MSTP(1)
9505                 IB=2*J-1+MOD(IA,2)
9506                 IPM=(5-ISIGN(1,I))/2
9507                 IDC=J+MDCY(IA,2)+2
9508                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9509                 MINT(20+JT)=ISIGN(IB,I)
9510                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9511                 IF(RVCKM.LE.0D0) GOTO 430
9512   420         CONTINUE
9513             ELSE
9514               IB=2*((IA+1)/2)-1+MOD(IA,2)
9515               MINT(20+JT)=ISIGN(IB,I)
9516             ENDIF
9517   430     CONTINUE
9518           KCC=22
9519           KFRES=KFHIGG
9520
9521         ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9522 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9523           IF(MINT(15).EQ.22) JS=2
9524           MINT(23-JS)=21
9525           KCC=24+JS
9526           KCS=ISIGN(1,MINT(14+JS))
9527
9528         ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9529 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9530           IF(MINT(15).EQ.22) JS=2
9531           KCC=22
9532           KCS=ISIGN(1,MINT(14+JS))
9533
9534         ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9535 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9536           KCS=(-1)**INT(1.5D0+PYR(0))
9537           MINT(21)=ISIGN(KFLF,KCS)
9538           MINT(22)=-MINT(21)
9539           KCC=27
9540           IF(MINT(16).EQ.21) KCC=28
9541
9542         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9543 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9544           KCS=(-1)**INT(1.5D0+PYR(0))
9545           MINT(21)=ISIGN(KFLF,KCS)
9546           MINT(22)=-MINT(21)
9547           KCC=21
9548
9549         ENDIF
9550
9551       ELSEIF(ISUB.LE.160) THEN
9552         IF(ISUB.EQ.141) THEN
9553 C...f + fbar -> gamma*/Z0/Z'0
9554           KFRES=32
9555
9556         ELSEIF(ISUB.EQ.142) THEN
9557 C...f + fbar' -> W'+/-
9558           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9559           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9560           KFRES=ISIGN(34,KCH1+KCH2)
9561
9562         ELSEIF(ISUB.EQ.143) THEN
9563 C...f + fbar' -> H+/-
9564           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9565           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9566           KFRES=ISIGN(37,KCH1+KCH2)
9567
9568         ELSEIF(ISUB.EQ.144) THEN
9569 C...f + fbar' -> R
9570           KFRES=ISIGN(41,MINT(15)+MINT(16))
9571
9572         ELSEIF(ISUB.EQ.145) THEN
9573 C...q + l -> LQ (leptoquark)
9574           IF(IABS(MINT(16)).LE.8) JS=2
9575           KFRES=ISIGN(42,MINT(14+JS))
9576           KCC=28+JS
9577           KCS=ISIGN(1,MINT(14+JS))
9578
9579         ELSEIF(ISUB.EQ.146) THEN
9580 C...e + gamma -> e* (excited lepton)
9581           IF(MINT(15).EQ.22) JS=2
9582           KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9583           KCC=22
9584
9585         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9586 C...q + g -> q* (excited quark)
9587           IF(MINT(15).EQ.21) JS=2
9588           KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9589           KCC=30+JS
9590           KCS=ISIGN(1,MINT(14+JS))
9591
9592         ELSEIF(ISUB.EQ.149) THEN
9593 C...g + g -> eta_tc
9594           KFRES=KTECHN+331
9595           KCC=23
9596           KCS=(-1)**INT(1.5D0+PYR(0))
9597         ENDIF
9598
9599       ELSEIF(ISUB.LE.200) THEN
9600         IF(ISUB.EQ.161) THEN
9601 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9602           IF(MINT(15).EQ.21) JS=2
9603           I=MINT(14+JS)
9604           IA=IABS(I)
9605           MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9606           IB=IA+MOD(IA,2)-MOD(IA+1,2)
9607           MINT(20+JS)=ISIGN(IB,I)
9608           KCC=15+JS
9609           KCS=ISIGN(1,MINT(14+JS))
9610
9611         ELSEIF(ISUB.EQ.162) THEN
9612 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9613           IF(MINT(15).EQ.21) JS=2
9614           MINT(20+JS)=ISIGN(42,MINT(14+JS))
9615           KFLQL=KFDP(MDCY(42,2),2)
9616           MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9617           KCC=15+JS
9618           KCS=ISIGN(1,MINT(14+JS))
9619
9620         ELSEIF(ISUB.EQ.163) THEN
9621 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9622           KCS=(-1)**INT(1.5D0+PYR(0))
9623           MINT(21)=ISIGN(42,KCS)
9624           MINT(22)=-MINT(21)
9625           KCC=MINT(2)+10
9626
9627         ELSEIF(ISUB.EQ.164) THEN
9628 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9629           MINT(21)=ISIGN(42,MINT(15))
9630           MINT(22)=-MINT(21)
9631           KCC=4
9632
9633         ELSEIF(ISUB.EQ.165) THEN
9634 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9635           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9636           MINT(22)=-MINT(21)
9637
9638         ELSEIF(ISUB.EQ.166) THEN
9639 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9640           IF(MOD(MINT(15),2).EQ.0) THEN
9641             MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9642             MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9643           ELSE
9644             MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9645             MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9646           ENDIF
9647
9648         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9649 C...q + q' -> q" + q* (excited quark)
9650           KFQSTR=KFPR(ISUB,2)
9651           KFQEXC=MOD(KFQSTR,KEXCIT)
9652           JS=MINT(2)
9653           MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9654           IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9655      &    MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9656           KCC=22
9657           JS=3-JS
9658
9659         ELSEIF(ISUB.EQ.169) THEN
9660 C...q + qbar -> e + e* (excited lepton)
9661           KFQSTR=KFPR(ISUB,2)
9662           KFQEXC=MOD(KFQSTR,KEXCIT)
9663           JS=MINT(2)
9664           MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9665           MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9666           JS=3-JS
9667
9668         ELSEIF(ISUB.EQ.191) THEN
9669 C...f + fbar -> rho_tc0.
9670           KFRES=KTECHN+113
9671
9672         ELSEIF(ISUB.EQ.192) THEN
9673 C...f + fbar' -> rho_tc+/-
9674           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9675           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9676           KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9677
9678         ELSEIF(ISUB.EQ.193) THEN
9679 C...f + fbar -> omega_tc0.
9680           KFRES=KTECHN+223
9681
9682         ELSEIF(ISUB.EQ.194) THEN
9683 C...f + fbar -> f' + fbar' via mixture of s-channel
9684 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9685           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9686           MINT(22)=-MINT(21)
9687
9688         ELSEIF(ISUB.EQ.195) THEN
9689 C...f + fbar' -> f'' + fbar''' via s-channel
9690 C...rho_tc+ th=(p(f)-p(f'))**2
9691 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9692           IF(MOD(MINT(15),2).EQ.0) THEN
9693             MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9694             MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9695           ELSE
9696             MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9697             MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9698           ENDIF
9699         ENDIF
9700
9701 CMRENNA++
9702       ELSEIF(ISUB.LE.215) THEN
9703         IF(ISUB.EQ.201) THEN
9704 C...f + fbar -> ~e_L + ~e_Lbar
9705           MINT(21)=ISIGN(KSUSY1+11,KCS)
9706           MINT(22)=-MINT(21)
9707
9708         ELSEIF(ISUB.EQ.202) THEN
9709 C...f + fbar -> ~e_R + ~e_Rbar
9710           MINT(21)=ISIGN(KSUSY2+11,KCS)
9711           MINT(22)=-MINT(21)
9712
9713         ELSEIF(ISUB.EQ.203) THEN
9714 C...f + fbar -> ~e_L + ~e_Rbar
9715           KCS=1
9716           IF(MINT(2).EQ.2) KCS=-1
9717           KS2=KSUSY2+11
9718           KS1=KSUSY1+11
9719           IF(KCS.EQ.-1) THEN
9720            KS2=KSUSY1+11
9721            KS1=KSUSY2+11
9722            JS=2
9723           ENDIF
9724           MINT(21)=ISIGN(KS1,MINT(15))
9725           MINT(22)=ISIGN(KS2,MINT(16))
9726
9727 c          KCS=1
9728 c          IF(MINT(2).EQ.2) KCS=-1
9729 C          MINT(21)=ISIGN(KSUSY1+11,KCS)
9730 C          MINT(22)=-ISIGN(KSUSY2+11,KCS)
9731 c          IF(KCS.EQ.-1) THEN
9732 C          KS1=KSUSY1+11
9733 C          KS2=KSUSY2+11
9734 C          JS=2
9735 c          ENDIF
9736 c          MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9737 c          MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9738
9739         ELSEIF(ISUB.EQ.204) THEN
9740 C...f + fbar -> ~mu_L + ~mu_Lbar
9741           MINT(21)=ISIGN(KSUSY1+13,KCS)
9742           MINT(22)=-MINT(21)
9743
9744         ELSEIF(ISUB.EQ.205) THEN
9745 C...f + fbar -> ~mu_R + ~mu_Rbar
9746           MINT(21)=ISIGN(KSUSY2+13,KCS)
9747           MINT(22)=-MINT(21)
9748
9749         ELSEIF(ISUB.EQ.206) THEN
9750 C...f + fbar -> ~mu_L + ~mu_Rbar
9751           KCS=1
9752           IF(MINT(2).EQ.2) KCS=-1
9753           KS2=KSUSY2+13
9754           KS1=KSUSY1+13
9755           IF(KCS.EQ.-1) THEN
9756            KS2=KSUSY1+13
9757            KS1=KSUSY2+13
9758            JS=2
9759           ENDIF
9760           MINT(21)=ISIGN(KS1,MINT(15))
9761           MINT(22)=ISIGN(KS2,MINT(16))
9762 c          MINT(21)=ISIGN(KSUSY1+13,KCS)
9763 c          MINT(22)=-ISIGN(KSUSY2+13,KCS)
9764
9765         ELSEIF(ISUB.EQ.207) THEN
9766 C...f + fbar -> ~tau_1 + ~tau_1bar
9767           MINT(21)=ISIGN(KSUSY1+15,KCS)
9768           MINT(22)=-MINT(21)
9769
9770         ELSEIF(ISUB.EQ.208) THEN
9771 C...f + fbar -> ~tau_2 + ~tau_2bar
9772           MINT(21)=ISIGN(KSUSY2+15,KCS)
9773           MINT(22)=-MINT(21)
9774
9775         ELSEIF(ISUB.EQ.209) THEN
9776 C...f + fbar -> ~tau_1 + ~tau_2bar
9777           KCS=1
9778           IF(MINT(2).EQ.2) KCS=-1
9779           KS2=KSUSY2+15
9780           KS1=KSUSY1+15
9781           IF(KCS.EQ.-1) THEN
9782            KS2=KSUSY1+15
9783            KS1=KSUSY2+15
9784            JS=2
9785           ENDIF
9786           MINT(21)=ISIGN(KS1,MINT(15))
9787           MINT(22)=ISIGN(KS2,MINT(16))
9788 C          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9789 C          IF(MINT(2).EQ.1) THEN
9790 C            MINT(21)= ISIGN(KSUSY1+15,KCH1)
9791 C            MINT(22)= -ISIGN(KSUSY2+15,KCH1)
9792 C          ELSE
9793 C            MINT(21)= ISIGN(KSUSY2+15,KCH1)
9794 C            MINT(22)= -ISIGN(KSUSY1+15,KCH1)
9795 C            JS=2
9796 C          ENDIF
9797
9798         ELSEIF(ISUB.EQ.210) THEN
9799 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9800           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9801           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9802           MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9803           MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9804
9805         ELSEIF(ISUB.EQ.211) THEN
9806 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9807           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9808           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9809           MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9810           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9811
9812         ELSEIF(ISUB.EQ.212) THEN
9813 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9814           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9815           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9816           MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9817           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9818
9819         ELSEIF(ISUB.EQ.213) THEN
9820 C...f + fbar -> ~nul + ~nulbar
9821           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9822           MINT(22)=-MINT(21)
9823
9824         ELSEIF(ISUB.EQ.214) THEN
9825 C...f + fbar -> ~nutau + ~nutaubar
9826           MINT(21)=ISIGN(KSUSY1+16,KCS)
9827           MINT(22)=-MINT(21)
9828         ENDIF
9829
9830       ELSEIF(ISUB.LE.225) THEN
9831         IF(ISUB.EQ.216) THEN
9832 C...f + fbar -> ~chi01 + ~chi01
9833           MINT(21)=KSUSY1+22
9834           MINT(22)=KSUSY1+22
9835
9836         ELSEIF(ISUB.EQ.217) THEN
9837 C...f + fbar -> ~chi02 + ~chi02
9838           MINT(21)=KSUSY1+23
9839           MINT(22)=KSUSY1+23
9840
9841         ELSEIF(ISUB.EQ.218 ) THEN
9842 C...f + fbar -> ~chi03 + ~chi03
9843           MINT(21)=KSUSY1+25
9844           MINT(22)=KSUSY1+25
9845
9846         ELSEIF(ISUB.EQ.219 ) THEN
9847 C...f + fbar -> ~chi04 + ~chi04
9848           MINT(21)=KSUSY1+35
9849           MINT(22)=KSUSY1+35
9850
9851         ELSEIF(ISUB.EQ.220 ) THEN
9852 C...f + fbar -> ~chi01 + ~chi02
9853           IF(MINT(15).LT.0) JS=2
9854 C          IF(PYR(0).GT.0.5D0) JS=2
9855           MINT(20+JS)=KSUSY1+22
9856           MINT(23-JS)=KSUSY1+23
9857
9858         ELSEIF(ISUB.EQ.221 ) THEN
9859 C...f + fbar -> ~chi01 + ~chi03
9860           IF(MINT(15).LT.0) JS=2
9861 C          IF(PYR(0).GT.0.5D0) JS=2
9862           MINT(20+JS)=KSUSY1+22
9863           MINT(23-JS)=KSUSY1+25
9864
9865         ELSEIF(ISUB.EQ.222) THEN
9866 C...f + fbar -> ~chi01 + ~chi04
9867           IF(MINT(15).LT.0) JS=2
9868 C          IF(PYR(0).GT.0.5D0) JS=2
9869           MINT(20+JS)=KSUSY1+22
9870           MINT(23-JS)=KSUSY1+35
9871
9872         ELSEIF(ISUB.EQ.223) THEN
9873 C...f + fbar -> ~chi02 + ~chi03
9874           IF(MINT(15).LT.0) JS=2
9875 C          IF(PYR(0).GT.0.5D0) JS=2
9876           MINT(20+JS)=KSUSY1+23
9877           MINT(23-JS)=KSUSY1+25
9878
9879         ELSEIF(ISUB.EQ.224) THEN
9880 C...f + fbar -> ~chi02 + ~chi04
9881           IF(MINT(15).LT.0) JS=2
9882 C          IF(PYR(0).GT.0.5D0) JS=2
9883           MINT(20+JS)=KSUSY1+23
9884           MINT(23-JS)=KSUSY1+35
9885
9886         ELSEIF(ISUB.EQ.225) THEN
9887 C...f + fbar -> ~chi03 + ~chi04
9888           IF(MINT(15).LT.0) JS=2
9889 C          IF(PYR(0).GT.0.5D0) JS=2
9890           MINT(20+JS)=KSUSY1+25
9891           MINT(23-JS)=KSUSY1+35
9892         ENDIF
9893
9894       ELSEIF(ISUB.LE.236) THEN
9895         IF(ISUB.EQ.226) THEN
9896 C...f + fbar -> ~chi+-1 + ~chi-+1
9897 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9898           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9899           MINT(21)=ISIGN(KSUSY1+24,KCH1)
9900           MINT(22)=-MINT(21)
9901
9902         ELSEIF(ISUB.EQ.227) THEN
9903 C...f + fbar -> ~chi+-2 + ~chi-+2
9904           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9905           MINT(21)=ISIGN(KSUSY1+37,KCH1)
9906           MINT(22)=-MINT(21)
9907
9908         ELSEIF(ISUB.EQ.228) THEN
9909 C...f + fbar -> ~chi+-1 + ~chi-+2
9910 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9911 C...js=1 if pyr<.5, js=2 if pyr>.5
9912 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9913 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9914 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9915 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9916           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9917           KCH2=INT(1-KCH1)/2
9918           IF(MINT(2).EQ.1) THEN
9919             MINT(21)= ISIGN(KSUSY1+24,KCH1)
9920             MINT(22)= -ISIGN(KSUSY1+37,KCH1)
9921 c            IF(KCH2.EQ.0) JS=2
9922           ELSE
9923             MINT(21)= ISIGN(KSUSY1+37,KCH1)
9924             MINT(22)= -ISIGN(KSUSY1+24,KCH1)
9925             JS=2
9926 c            IF(KCH2.EQ.1) JS=2
9927           ENDIF
9928
9929         ELSEIF(ISUB.EQ.229) THEN
9930 C...q + qbar' -> ~chi01 + ~chi+-1
9931 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9932           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9933           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9934 C...CHECK THIS
9935           IF(MOD(MINT(15),2).EQ.0) JS=2
9936           MINT(20+JS)=KSUSY1+22
9937           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9938
9939         ELSEIF(ISUB.EQ.230) THEN
9940 C...q + qbar' -> ~chi02 + ~chi+-1
9941           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9942           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9943           IF(MOD(MINT(15),2).EQ.0) JS=2
9944           MINT(20+JS)=KSUSY1+23
9945           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9946
9947         ELSEIF(ISUB.EQ.231) THEN
9948 C...q + qbar' -> ~chi03 + ~chi+-1
9949           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9950           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9951           IF(MOD(MINT(15),2).EQ.0) JS=2
9952           MINT(20+JS)=KSUSY1+25
9953           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9954
9955         ELSEIF(ISUB.EQ.232) THEN
9956 C...q + qbar' -> ~chi04 + ~chi+-1
9957           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9958           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9959           IF(MOD(MINT(15),2).EQ.0) JS=2
9960           MINT(20+JS)=KSUSY1+35
9961           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9962
9963         ELSEIF(ISUB.EQ.233) THEN
9964 C...q + qbar' -> ~chi01 + ~chi+-2
9965           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9966           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9967           IF(MOD(MINT(15),2).EQ.0) JS=2
9968           MINT(20+JS)=KSUSY1+22
9969           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9970
9971         ELSEIF(ISUB.EQ.234) THEN
9972 C...q + qbar' -> ~chi02 + ~chi+-2
9973           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9974           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9975           IF(MOD(MINT(15),2).EQ.0) JS=2
9976           MINT(20+JS)=KSUSY1+23
9977           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9978
9979         ELSEIF(ISUB.EQ.235) THEN
9980 C...q + qbar' -> ~chi03 + ~chi+-2
9981           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9982           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9983           IF(MOD(MINT(15),2).EQ.0) JS=2
9984           MINT(20+JS)=KSUSY1+25
9985           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9986
9987         ELSEIF(ISUB.EQ.236) THEN
9988 C...q + qbar' -> ~chi04 + ~chi+-2
9989           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9990           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9991           IF(MOD(MINT(15),2).EQ.0) JS=2
9992           MINT(20+JS)=KSUSY1+35
9993           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9994         ENDIF
9995
9996       ELSEIF(ISUB.LE.245) THEN
9997         IF(ISUB.EQ.237) THEN
9998 C...q + qbar -> ~chi01 + ~g
9999 C...th arbitrary
10000           IF(PYR(0).GT.0.5D0) JS=2
10001           MINT(20+JS)=KSUSY1+21
10002           MINT(23-JS)=KSUSY1+22
10003           KCC=17+JS
10004
10005         ELSEIF(ISUB.EQ.238) THEN
10006 C...q + qbar -> ~chi02 + ~g
10007 C...th arbitrary
10008           IF(PYR(0).GT.0.5D0) JS=2
10009           MINT(20+JS)=KSUSY1+21
10010           MINT(23-JS)=KSUSY1+23
10011           KCC=17+JS
10012
10013         ELSEIF(ISUB.EQ.239) THEN
10014 C...q + qbar -> ~chi03 + ~g
10015 C...th arbitrary
10016           IF(PYR(0).GT.0.5D0) JS=2
10017           MINT(20+JS)=KSUSY1+21
10018           MINT(23-JS)=KSUSY1+25
10019           KCC=17+JS
10020
10021         ELSEIF(ISUB.EQ.240) THEN
10022 C...q + qbar -> ~chi04 + ~g
10023 C...th arbitrary
10024           IF(PYR(0).GT.0.5D0) JS=2
10025           MINT(20+JS)=KSUSY1+21
10026           MINT(23-JS)=KSUSY1+35
10027           KCC=17+JS
10028
10029         ELSEIF(ISUB.EQ.241) THEN
10030 C...q + qbar' -> ~chi+-1 + ~g
10031 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10032 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10033 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10034 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10035 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10036           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10037           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10038           JS=1
10039           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10040           MINT(20+JS)=KSUSY1+21
10041           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10042           KCC=17+JS
10043
10044         ELSEIF(ISUB.EQ.242) THEN
10045 C...q + qbar' -> ~chi+-2 + ~g
10046 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10047 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10048 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10049 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10050 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10051           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10052           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10053           JS=1
10054           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10055           MINT(20+JS)=KSUSY1+21
10056           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10057           KCC=17+JS
10058
10059         ELSEIF(ISUB.EQ.243) THEN
10060 C...q + qbar -> ~g + ~g ; th arbitrary
10061           MINT(21)=KSUSY1+21
10062           MINT(22)=KSUSY1+21
10063           KCC=MINT(2)+4
10064
10065         ELSEIF(ISUB.EQ.244) THEN
10066 C...g + g -> ~g + ~g ; th arbitrary
10067           KCC=MINT(2)+12
10068           KCS=(-1)**INT(1.5D0+PYR(0))
10069           MINT(21)=KSUSY1+21
10070           MINT(22)=KSUSY1+21
10071         ENDIF
10072
10073       ELSEIF(ISUB.LE.260) THEN
10074         IF(ISUB.EQ.246) THEN
10075 C...qj + g -> ~qj_L + ~chi01
10076           IF(MINT(15).EQ.21) JS=2
10077           I=MINT(14+JS)
10078           IA=IABS(I)
10079           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10080           MINT(23-JS)=KSUSY1+22
10081           KCC=15+JS
10082           KCS=ISIGN(1,MINT(14+JS))
10083
10084         ELSEIF(ISUB.EQ.247) THEN
10085 C...qj + g -> ~qj_R + ~chi01
10086           IF(MINT(15).EQ.21) JS=2
10087           I=MINT(14+JS)
10088           IA=IABS(I)
10089           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10090           MINT(23-JS)=KSUSY1+22
10091           KCC=15+JS
10092           KCS=ISIGN(1,MINT(14+JS))
10093
10094         ELSEIF(ISUB.EQ.248) THEN
10095 C...qj + g -> ~qj_L + ~chi02
10096           IF(MINT(15).EQ.21) JS=2
10097           I=MINT(14+JS)
10098           IA=IABS(I)
10099           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10100           MINT(23-JS)=KSUSY1+23
10101           KCC=15+JS
10102           KCS=ISIGN(1,MINT(14+JS))
10103
10104         ELSEIF(ISUB.EQ.249) THEN
10105 C...qj + g -> ~qj_R + ~chi02
10106           IF(MINT(15).EQ.21) JS=2
10107           I=MINT(14+JS)
10108           IA=IABS(I)
10109           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10110           MINT(23-JS)=KSUSY1+23
10111           KCC=15+JS
10112           KCS=ISIGN(1,MINT(14+JS))
10113
10114         ELSEIF(ISUB.EQ.250) THEN
10115 C...qj + g -> ~qj_L + ~chi03
10116           IF(MINT(15).EQ.21) JS=2
10117           I=MINT(14+JS)
10118           IA=IABS(I)
10119           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10120           MINT(23-JS)=KSUSY1+25
10121           KCC=15+JS
10122           KCS=ISIGN(1,MINT(14+JS))
10123
10124         ELSEIF(ISUB.EQ.251) THEN
10125 C...qj + g -> ~qj_R + ~chi03
10126           IF(MINT(15).EQ.21) JS=2
10127           I=MINT(14+JS)
10128           IA=IABS(I)
10129           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10130           MINT(23-JS)=KSUSY1+25
10131           KCC=15+JS
10132           KCS=ISIGN(1,MINT(14+JS))
10133
10134         ELSEIF(ISUB.EQ.252) THEN
10135 C...qj + g -> ~qj_L + ~chi04
10136           IF(MINT(15).EQ.21) JS=2
10137           I=MINT(14+JS)
10138           IA=IABS(I)
10139           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10140           MINT(23-JS)=KSUSY1+35
10141           KCC=15+JS
10142           KCS=ISIGN(1,MINT(14+JS))
10143
10144         ELSEIF(ISUB.EQ.253) THEN
10145 C...qj + g -> ~qj_R + ~chi04
10146           IF(MINT(15).EQ.21) JS=2
10147           I=MINT(14+JS)
10148           IA=IABS(I)
10149           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10150           MINT(23-JS)=KSUSY1+35
10151           KCC=15+JS
10152           KCS=ISIGN(1,MINT(14+JS))
10153
10154         ELSEIF(ISUB.EQ.254) THEN
10155 C...qj + g -> ~qk_L + ~chi+-1
10156           IF(MINT(15).EQ.21) JS=2
10157           I=MINT(14+JS)
10158           IA=IABS(I)
10159           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10160           IB=-IA+INT((IA+1)/2)*4-1
10161           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10162           KCC=15+JS
10163           KCS=ISIGN(1,MINT(14+JS))
10164
10165         ELSEIF(ISUB.EQ.255) THEN
10166 C...qj + g -> ~qk_L + ~chi+-1
10167           IF(MINT(15).EQ.21) JS=2
10168           I=MINT(14+JS)
10169           IA=IABS(I)
10170           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10171           IB=-IA+INT((IA+1)/2)*4-1
10172           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10173           KCC=15+JS
10174           KCS=ISIGN(1,MINT(14+JS))
10175
10176         ELSEIF(ISUB.EQ.256) THEN
10177 C...qj + g -> ~qk_L + ~chi+-2
10178           IF(MINT(15).EQ.21) JS=2
10179           I=MINT(14+JS)
10180           IA=IABS(I)
10181           IB=-IA+INT((IA+1)/2)*4-1
10182           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10183           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10184           KCC=15+JS
10185           KCS=ISIGN(1,MINT(14+JS))
10186
10187         ELSEIF(ISUB.EQ.257) THEN
10188 C...qj + g -> ~qk_R + ~chi+-2
10189           IF(MINT(15).EQ.21) JS=2
10190           I=MINT(14+JS)
10191           IA=IABS(I)
10192           IB=-IA+INT((IA+1)/2)*4-1
10193           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10194           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10195           KCC=15+JS
10196           KCS=ISIGN(1,MINT(14+JS))
10197
10198         ELSEIF(ISUB.EQ.258) THEN
10199 C...qj + g -> ~qj_L + ~g
10200           IF(MINT(15).EQ.21) JS=2
10201           I=MINT(14+JS)
10202           IA=IABS(I)
10203           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10204           MINT(23-JS)=KSUSY1+21
10205           KCC=MINT(2)+6
10206           IF(JS.EQ.2) KCC=KCC+2
10207           KCS=ISIGN(1,I)
10208
10209         ELSEIF(ISUB.EQ.259) THEN
10210 C...qj + g -> ~qj_R + ~g
10211           IF(MINT(15).EQ.21) JS=2
10212           I=MINT(14+JS)
10213           IA=IABS(I)
10214           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10215           MINT(23-JS)=KSUSY1+21
10216           KCC=MINT(2)+6
10217           IF(JS.EQ.2) KCC=KCC+2
10218           KCS=ISIGN(1,I)
10219         ENDIF
10220
10221       ELSEIF(ISUB.LE.270) THEN
10222         IF(ISUB.EQ.261) THEN
10223 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10224           ISGN=1
10225           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10226           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10227           MINT(22)=-MINT(21)
10228 C...Correct color combination
10229           IF(MINT(43).EQ.4) KCC=4
10230
10231         ELSEIF(ISUB.EQ.262) THEN
10232 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10233           ISGN=1
10234           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10235           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10236           MINT(22)=-MINT(21)
10237 C...Correct color combination
10238           IF(MINT(43).EQ.4) KCC=4
10239
10240         ELSEIF(ISUB.EQ.263) THEN
10241 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10242           IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10243      &    (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10244             MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10245             MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10246           ELSE
10247             JS=2
10248             MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10249             MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10250           ENDIF
10251 C...Correct color combination
10252           IF(MINT(43).EQ.4) KCC=4
10253
10254         ELSEIF(ISUB.EQ.264) THEN
10255 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10256           KCS=(-1)**INT(1.5D0+PYR(0))
10257           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10258           MINT(22)=-MINT(21)
10259           KCC=MINT(2)+10
10260
10261         ELSEIF(ISUB.EQ.265) THEN
10262 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10263           KCS=(-1)**INT(1.5D0+PYR(0))
10264           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10265           MINT(22)=-MINT(21)
10266           KCC=MINT(2)+10
10267         ENDIF
10268
10269       ELSEIF(ISUB.LE.296) THEN
10270         IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10271 C...qi + qj -> ~qi_L + ~qj_L
10272           KCC=MINT(2)
10273           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10274           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10275           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10276
10277         ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10278 C...qi + qj -> ~qi_R + ~qj_R
10279           KCC=MINT(2)
10280           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10281           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10282           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10283
10284         ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10285 C...qi + qj -> ~qi_L + ~qj_R
10286           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10287           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10288           KCC=MINT(2)
10289           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10290
10291         ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10292 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10293           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10294           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10295           KCC=MINT(2)
10296           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10297
10298         ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10299 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10300           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10301           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10302           KCC=MINT(2)
10303           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10304
10305         ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10306 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10307           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10308           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10309           KCC=MINT(2)
10310           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10311
10312         ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10313 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10314           ISGN=1
10315           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10316           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10317           MINT(22)=-MINT(21)
10318           IF(MINT(43).EQ.4) KCC=4
10319
10320         ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10321 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10322           ISGN=1
10323           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10324           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10325           MINT(22)=-MINT(21)
10326           IF(MINT(43).EQ.4) KCC=4
10327
10328         ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10329 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10330 C...pure LL + RR
10331           KCS=(-1)**INT(1.5D0+PYR(0))
10332           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10333           MINT(22)=-MINT(21)
10334           KCC=MINT(2)+10
10335
10336         ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10337 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10338           KCS=(-1)**INT(1.5D0+PYR(0))
10339           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10340           MINT(22)=-MINT(21)
10341           KCC=MINT(2)+10
10342
10343         ELSEIF(ISUB.EQ.294) THEN
10344 C...qj + g -> ~qj_L + ~g
10345           IF(MINT(15).EQ.21) JS=2
10346           I=MINT(14+JS)
10347           IA=IABS(I)
10348           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10349           MINT(23-JS)=KSUSY1+21
10350           KCC=MINT(2)+6
10351           IF(JS.EQ.2) KCC=KCC+2
10352           KCS=ISIGN(1,I)
10353
10354         ELSEIF(ISUB.EQ.295) THEN
10355 C...qj + g -> ~qj_R + ~g
10356           IF(MINT(15).EQ.21) JS=2
10357           I=MINT(14+JS)
10358           IA=IABS(I)
10359           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10360           MINT(23-JS)=KSUSY1+21
10361           KCC=MINT(2)+6
10362           IF(JS.EQ.2) KCC=KCC+2
10363           KCS=ISIGN(1,I)
10364         ENDIF
10365
10366       ELSEIF(ISUB.LE.340) THEN
10367
10368         IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10369 C...q + qbar' -> H+ + H0
10370           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10371           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10372           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10373           MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10374           MINT(23-JS)=KFPR(ISUB,2)
10375         ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10376 C...f + fbar -> A0 + H0; th arbitrary
10377           IF(PYR(0).GT.0.5D0) JS=2
10378           MINT(20+JS)=KFPR(ISUB,1)
10379           MINT(23-JS)=KFPR(ISUB,2)
10380         ELSEIF(ISUB.EQ.301) THEN
10381 C...f + fbar -> H+ H-
10382           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10383           MINT(22)=-MINT(21)
10384         ENDIF
10385 CMRENNA--
10386
10387       ELSEIF(ISUB.LE.360) THEN
10388
10389         IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10390 C...l + l -> H_L++/--, H_R++/--
10391           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10392           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10393           KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10394
10395         ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10396 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10397           IF(MINT(15).EQ.22) JS=2
10398           MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10399           MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10400           KCC=22
10401
10402         ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10403 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10404           MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10405           MINT(22)=-MINT(21)
10406
10407         ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10408 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10409 C...as inner process).
10410           DO 450 JT=1,2
10411             I=MINT(14+JT)
10412             IA=IABS(I)
10413             IF(IA.LE.10) THEN
10414               RVCKM=VINT(180+I)*PYR(0)
10415               DO 440 J=1,MSTP(1)
10416                 IB=2*J-1+MOD(IA,2)
10417                 IPM=(5-ISIGN(1,I))/2
10418                 IDC=J+MDCY(IA,2)+2
10419                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10420                 MINT(20+JT)=ISIGN(IB,I)
10421                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10422                 IF(RVCKM.LE.0D0) GOTO 450
10423   440         CONTINUE
10424             ELSE
10425               IB=2*((IA+1)/2)-1+MOD(IA,2)
10426               MINT(20+JT)=ISIGN(IB,I)
10427             ENDIF
10428   450     CONTINUE
10429           KCC=22
10430           KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10431           IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10432
10433         ELSEIF(ISUB.EQ.353) THEN
10434 C...f + fbar -> Z_R0
10435           KFRES=KFPR(ISUB,1)
10436
10437         ELSEIF(ISUB.EQ.354) THEN
10438 C...f + fbar' -> W+/-
10439           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10440           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10441           KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10442
10443         ENDIF
10444
10445       ELSEIF(ISUB.LE.380) THEN
10446
10447         IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10448 C...f + fbar -> charged+ charged- technicolor
10449           KSW=(-1)**INT(1.5D0+PYR(0))
10450           MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10451           MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10452
10453         ELSEIF(ISUB.LE.367) THEN
10454 C...f + fbar -> neutral neutral technicolor
10455           MINT(21)=KFPR(ISUB,1)
10456           MINT(22)=KFPR(ISUB,2)
10457
10458         ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10459 C...f + fbar' -> neutral charged technicolor
10460           IN=1
10461           IC=2
10462           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10463           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10464           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10465           MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10466           MINT(20+JS)=KFPR(ISUB,IN)
10467
10468         ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10469 C...f + fbar' -> charged neutral technicolor
10470           IN=2
10471           IC=1
10472           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10473           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10474           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10475           MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10476           MINT(23-JS)=KFPR(ISUB,IN)
10477         ENDIF
10478
10479       ELSEIF(ISUB.LE.400) THEN
10480         IF(ISUB.EQ.391) THEN
10481 C...f + fbar -> G*.
10482           KFRES=KFPR(ISUB,1)
10483
10484         ELSEIF(ISUB.EQ.392) THEN
10485 C...g + g -> G*.
10486           KCC=21
10487           KFRES=KFPR(ISUB,1)
10488
10489         ELSEIF(ISUB.EQ.393) THEN
10490 C...q + qbar -> g + G*;  th arbitrary.
10491           IF(PYR(0).GT.0.5D0) JS=2
10492           MINT(20+JS)=KFPR(ISUB,1)
10493           MINT(23-JS)=KFPR(ISUB,2)
10494           KCC=17+JS
10495
10496         ELSEIF(ISUB.EQ.394) THEN
10497 C...q + g -> q + G*;  th = (p(f) - p(f))**2
10498           IF(MINT(15).EQ.21) JS=2
10499           MINT(23-JS)=KFPR(ISUB,2)
10500           KCC=15+JS
10501           KCS=ISIGN(1,MINT(14+JS))
10502
10503         ELSEIF(ISUB.EQ.395) THEN
10504 C...g + g -> G* + g;  th arbitrary.
10505           IF(PYR(0).GT.0.5D0) JS=2
10506           MINT(23-JS)=KFPR(ISUB,2)
10507           KCC=22+JS
10508         ENDIF
10509       ENDIF
10510
10511       IF(ISET(ISUB).EQ.11) THEN
10512 C...Store documentation for user-defined processes
10513         BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10514         KUPPO(1)=MINT(83)+5
10515         KUPPO(2)=MINT(83)+6
10516         I=MINT(83)+6
10517         DO 470 IUP=3,NUP
10518           KUPPO(IUP)=0
10519           IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10520             IDOC=IDOC-1
10521             MINT(4)=MINT(4)-1
10522             GOTO 470
10523           ENDIF
10524           I=I+1
10525           KUPPO(IUP)=I
10526           K(I,1)=21
10527           K(I,2)=IDUP(IUP)
10528           IF(IDUP(IUP).EQ.0) K(I,2)=90
10529           K(I,3)=0
10530           IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10531           K(I,4)=0
10532           K(I,5)=0
10533           DO 460 J=1,5
10534             P(I,J)=PUP(J,IUP)
10535   460     CONTINUE
10536           V(I,5)=VTIMUP(IUP)
10537   470   CONTINUE
10538         CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10539      &  -BEZUP)
10540
10541 C...Store final state partons for user-defined processes
10542         N=IPU2
10543         DO 490 IUP=3,NUP
10544           N=N+1
10545           K(N,1)=1
10546           IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10547           K(N,2)=IDUP(IUP)
10548           IF(IDUP(IUP).EQ.0) K(N,2)=90
10549           IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10550             K(N,3)=KUPPO(IUP)
10551           ELSE
10552             K(N,3)=MINT(84)+MOTHUP(1,IUP)
10553           ENDIF
10554           K(N,4)=0
10555           K(N,5)=0
10556           DO 480 J=1,5
10557             P(N,J)=PUP(J,IUP)
10558   480     CONTINUE
10559           V(N,5)=VTIMUP(IUP)
10560   490   CONTINUE
10561         CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10562
10563 C...Arrange colour flow for user-defined processes
10564         NLBL=0
10565         DO 540 IUP1=1,NUP
10566           I1=MINT(84)+IUP1
10567           IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10568           IF(K(I1,1).EQ.1) K(I1,1)=3
10569           IF(K(I1,1).EQ.11) K(I1,1)=14
10570 C...Find a not yet considered colour/anticolour line.
10571           DO 530 ISDE1=1,2
10572             IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10573             NMAT=0
10574             DO 500 ILBL=1,NLBL
10575               IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10576   500       CONTINUE
10577             IF(NMAT.EQ.0) THEN
10578               NLBL=NLBL+1
10579               ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10580 C...Find all others belonging to same line.
10581               I3=I1
10582               I4=0
10583               DO 520 IUP2=IUP1+1,NUP
10584                 I2=MINT(84)+IUP2
10585                 DO 510 ISDE2=1,2
10586                   IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10587                     IF(ISDE2.EQ.ISDE1) THEN
10588                       K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10589                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10590                       I3=I2
10591                     ELSEIF(I4.NE.0) THEN
10592                       K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10593                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10594                       I4=I2
10595                     ELSEIF(IUP2.LE.2) THEN
10596                       K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10597                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10598                       I4=I2
10599                     ELSE
10600                       K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10601                       K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10602                       I4=I2
10603                     ENDIF
10604                   ENDIF
10605   510           CONTINUE
10606   520         CONTINUE
10607             ENDIF
10608   530     CONTINUE
10609   540   CONTINUE
10610
10611       ELSEIF(IDOC.EQ.7) THEN
10612 C...Resonance not decaying; store kinematics
10613         I=MINT(83)+7
10614         K(IPU3,1)=1
10615         K(IPU3,2)=KFRES
10616         K(IPU3,3)=I
10617         P(IPU3,4)=SHUSER
10618         P(IPU3,5)=SHUSER
10619         K(I,1)=21
10620         K(I,2)=KFRES
10621         P(I,4)=SHUSER
10622         P(I,5)=SHUSER
10623         N=IPU3
10624         MINT(21)=KFRES
10625         MINT(22)=0
10626
10627 C...Special cases: colour flow in coloured resonances
10628         KCRES=PYCOMP(KFRES)
10629         IF(KCHG(KCRES,2).NE.0) THEN
10630           K(IPU3,1)=3
10631           DO 550 J=1,2
10632             JC=J
10633             IF(KCS.EQ.-1) JC=3-J
10634             IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10635      &      MINT(84)+ICOL(KCC,1,JC)
10636             IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10637      &      MINT(84)+ICOL(KCC,2,JC)
10638             IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10639      &      MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10640   550     CONTINUE
10641         ELSE
10642           K(IPU1,4)=IPU2
10643           K(IPU1,5)=IPU2
10644           K(IPU2,4)=IPU1
10645           K(IPU2,5)=IPU1
10646         ENDIF
10647
10648       ELSEIF(IDOC.EQ.8) THEN
10649 C...2 -> 2 processes: store outgoing partons in their CM-frame
10650         DO 560 JT=1,2
10651           I=MINT(84)+2+JT
10652           KCA=PYCOMP(MINT(20+JT))
10653           K(I,1)=1
10654           IF(KCHG(KCA,2).NE.0) K(I,1)=3
10655           K(I,2)=MINT(20+JT)
10656           K(I,3)=MINT(83)+IDOC+JT-2
10657           KFAA=IABS(K(I,2))
10658           IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10659             P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10660           ELSE
10661             P(I,5)=PYMASS(K(I,2))
10662           ENDIF
10663           IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10664      &    P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10665   560   CONTINUE
10666         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10667           KFA1=IABS(MINT(21))
10668           KFA2=IABS(MINT(22))
10669           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10670      &    THEN
10671             MINT(51)=1
10672             RETURN
10673           ENDIF
10674           P(IPU3,5)=0D0
10675           P(IPU4,5)=0D0
10676         ENDIF
10677         P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10678         P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10679         P(IPU4,4)=SHR-P(IPU3,4)
10680         P(IPU4,3)=-P(IPU3,3)
10681         N=IPU4
10682         MINT(7)=MINT(83)+7
10683         MINT(8)=MINT(83)+8
10684
10685 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10686         CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10687
10688       ELSEIF(IDOC.EQ.9) THEN
10689 C...2 -> 3 processes: store outgoing partons in their CM frame
10690         DO 570 JT=1,2
10691           I=MINT(84)+2+JT
10692           KCA=PYCOMP(MINT(20+JT))
10693           K(I,1)=1
10694           IF(KCHG(KCA,2).NE.0) K(I,1)=3
10695           K(I,2)=MINT(20+JT)
10696           K(I,3)=MINT(83)+IDOC+JT-3
10697           IF(IABS(K(I,2)).LE.22) THEN
10698             P(I,5)=PYMASS(K(I,2))
10699           ELSE
10700             P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10701           ENDIF
10702           PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10703           P(I,1)=PT*COS(VINT(198+5*JT))
10704           P(I,2)=PT*SIN(VINT(198+5*JT))
10705   570   CONTINUE
10706         K(IPU5,1)=1
10707         K(IPU5,2)=KFRES
10708         K(IPU5,3)=MINT(83)+IDOC
10709         P(IPU5,5)=SHR
10710         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10711         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10712         PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10713         PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10714         PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10715         PMT3=SQRT(PMS3)
10716         P(IPU5,3)=PMT3*SINH(VINT(211))
10717         P(IPU5,4)=PMT3*COSH(VINT(211))
10718         PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10719         SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10720         IF(SQL12.LE.0D0) THEN
10721           MINT(51)=1
10722           RETURN
10723         ENDIF
10724         P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10725      &  VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10726         P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10727         P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10728         P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10729         MINT(23)=KFRES
10730         N=IPU5
10731         MINT(7)=MINT(83)+7
10732         MINT(8)=MINT(83)+8
10733
10734       ELSEIF(IDOC.EQ.11) THEN
10735 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10736         PHI(1)=PARU(2)*PYR(0)
10737         PHI(2)=PHI(1)-PHIR
10738         DO 580 JT=1,2
10739           I=MINT(84)+2+JT
10740           K(I,1)=1
10741           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10742           K(I,2)=MINT(20+JT)
10743           K(I,3)=MINT(83)+IDOC+JT-2
10744           P(I,5)=PYMASS(K(I,2))
10745           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10746             MINT(51)=1
10747             RETURN
10748           ENDIF
10749           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10750           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10751           P(I,1)=PTABS*COS(PHI(JT))
10752           P(I,2)=PTABS*SIN(PHI(JT))
10753           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10754           P(I,4)=0.5D0*SHPR*Z(JT)
10755           IZW=MINT(83)+6+JT
10756           K(IZW,1)=21
10757           K(IZW,2)=23
10758           IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10759           K(IZW,3)=IZW-2
10760           P(IZW,1)=-P(I,1)
10761           P(IZW,2)=-P(I,2)
10762           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10763           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10764           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10765   580   CONTINUE
10766         I=MINT(83)+9
10767         K(IPU5,1)=1
10768         K(IPU5,2)=KFRES
10769         K(IPU5,3)=I
10770         P(IPU5,5)=SHR
10771         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10772         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10773         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10774         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10775         K(I,1)=21
10776         K(I,2)=KFRES
10777         DO 590 J=1,5
10778           P(I,J)=P(IPU5,J)
10779   590   CONTINUE
10780         N=IPU5
10781         MINT(23)=KFRES
10782
10783       ELSEIF(IDOC.EQ.12) THEN
10784 C...Z0 and W+/- scattering: store bosons and outgoing partons
10785         PHI(1)=PARU(2)*PYR(0)
10786         PHI(2)=PHI(1)-PHIR
10787         JTRAN=INT(1.5D0+PYR(0))
10788         DO 600 JT=1,2
10789           I=MINT(84)+2+JT
10790           K(I,1)=1
10791           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10792           K(I,2)=MINT(20+JT)
10793           K(I,3)=MINT(83)+IDOC+JT-2
10794           P(I,5)=PYMASS(K(I,2))
10795           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10796           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10797           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10798           P(I,1)=PTABS*COS(PHI(JT))
10799           P(I,2)=PTABS*SIN(PHI(JT))
10800           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10801           P(I,4)=0.5D0*SHPR*Z(JT)
10802           IZW=MINT(83)+6+JT
10803           K(IZW,1)=21
10804           IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10805             K(IZW,2)=23
10806           ELSE
10807             K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
10808           ENDIF
10809           K(IZW,3)=IZW-2
10810           P(IZW,1)=-P(I,1)
10811           P(IZW,2)=-P(I,2)
10812           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10813           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10814           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10815           IPU=MINT(84)+4+JT
10816           K(IPU,1)=3
10817           K(IPU,2)=KFPR(ISUB,JT)
10818           IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
10819           IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
10820           K(IPU,3)=MINT(83)+8+JT
10821           IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
10822             P(IPU,5)=PYMASS(K(IPU,2))
10823           ELSE
10824             P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10825           ENDIF
10826           MINT(22+JT)=K(IPU,2)
10827   600   CONTINUE
10828 C...Find rotation and boost for hard scattering subsystem
10829         I1=MINT(83)+7
10830         I2=MINT(83)+8
10831         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
10832         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
10833         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
10834         GAMCM=(P(I1,4)+P(I2,4))/SHR
10835         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
10836         PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
10837         PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
10838         PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
10839         THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
10840         PHICM=PYANGL(PX,PY)
10841 C...Store hard scattering subsystem. Rotate and boost it
10842         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
10843      &  P(IPU6,5)**2
10844         PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
10845         CTHWZ=VINT(23)
10846         STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
10847         PHIWZ=VINT(24)-PHICM
10848         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
10849         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
10850         P(IPU5,3)=PABS*CTHWZ
10851         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
10852         P(IPU6,1)=-P(IPU5,1)
10853         P(IPU6,2)=-P(IPU5,2)
10854         P(IPU6,3)=-P(IPU5,3)
10855         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
10856         CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
10857         DO 620 JT=1,2
10858           I1=MINT(83)+8+JT
10859           I2=MINT(84)+4+JT
10860           K(I1,1)=21
10861           K(I1,2)=K(I2,2)
10862           DO 610 J=1,5
10863             P(I1,J)=P(I2,J)
10864   610     CONTINUE
10865   620   CONTINUE
10866         N=IPU6
10867         MINT(7)=MINT(83)+9
10868         MINT(8)=MINT(83)+10
10869       ENDIF
10870
10871       IF(ISET(ISUB).EQ.11) THEN
10872       ELSEIF(IDOC.GE.8) THEN
10873 C...Store colour connection indices
10874         DO 630 J=1,2
10875           JC=J
10876           IF(KCS.EQ.-1) JC=3-J
10877           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10878      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
10879           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10880      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
10881           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10882      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10883           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10884      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10885   630   CONTINUE
10886
10887 C...Copy outgoing partons to documentation lines
10888         IMAX=2
10889         IF(IDOC.EQ.9) IMAX=3
10890         DO 650 I=1,IMAX
10891           I1=MINT(83)+IDOC-IMAX+I
10892           I2=MINT(84)+2+I
10893           K(I1,1)=21
10894           K(I1,2)=K(I2,2)
10895           IF(IDOC.LE.9) K(I1,3)=0
10896           IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
10897           DO 640 J=1,5
10898             P(I1,J)=P(I2,J)
10899   640     CONTINUE
10900   650   CONTINUE
10901
10902       ELSEIF(IDOC.EQ.9) THEN
10903 C...Store colour connection indices
10904         DO 660 J=1,2
10905           JC=J
10906           IF(KCS.EQ.-1) JC=3-J
10907           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10908      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
10909      &    MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
10910           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10911      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
10912      &    MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
10913           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10914      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10915           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
10916      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10917   660   CONTINUE
10918
10919 C...Copy outgoing partons to documentation lines
10920         DO 680 I=1,3
10921           I1=MINT(83)+IDOC-3+I
10922           I2=MINT(84)+2+I
10923           K(I1,1)=21
10924           K(I1,2)=K(I2,2)
10925           K(I1,3)=0
10926           DO 670 J=1,5
10927             P(I1,J)=P(I2,J)
10928   670     CONTINUE
10929   680   CONTINUE
10930       ENDIF
10931
10932 C...Low-pT events: remove gluons used for string drawing purposes
10933       IF(ISUB.EQ.95) THEN
10934         K(IPU3,1)=K(IPU3,1)+10
10935         K(IPU4,1)=K(IPU4,1)+10
10936         DO 690 J=41,66
10937           VINTSV(J)=VINT(J)
10938           VINT(J)=0D0
10939   690   CONTINUE
10940         DO 710 I=MINT(83)+5,MINT(83)+8
10941           DO 700 J=1,5
10942             P(I,J)=0D0
10943   700     CONTINUE
10944   710   CONTINUE
10945       ENDIF
10946
10947       RETURN
10948       END
10949
10950 C*********************************************************************
10951
10952 C...PYSSPA
10953 C...Generates spacelike parton showers.
10954
10955       SUBROUTINE PYSSPA(IPU1,IPU2)
10956
10957 C...Double precision and integer declarations.
10958       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10959       IMPLICIT INTEGER(I-N)
10960       INTEGER PYK,PYCHGE,PYCOMP
10961 C...Commonblocks.
10962       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10963       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10964       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10965       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10966       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10967       COMMON/PYINT1/MINT(400),VINT(400)
10968       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10969       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10970       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10971      &/PYINT2/,/PYINT3/
10972 C...Local arrays and data.
10973       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
10974      &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
10975      &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
10976      &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
10977      &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
10978       DATA IS/2*0/
10979
10980 C...Read out basic information; set global Q^2 scale.
10981       IPUS1=IPU1
10982       IPUS2=IPU2
10983       ISUB=MINT(1)
10984       Q2MX=VINT(56)
10985       IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
10986       FCQ2MX=1D0
10987
10988 C...Define which processes ME corrections have been implemented for.
10989       MECOR=0
10990       IF(MSTP(68).EQ.1) THEN
10991         IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
10992      &  ISUB.EQ.144) MECOR=1
10993         IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
10994       ENDIF
10995
10996 C...Initialize QCD evolution and check phase space.
10997       Q2MNC=PARP(62)**2
10998       Q2MNCS(1)=Q2MNC
10999       Q2MNCS(2)=Q2MNC
11000       IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11001         Q0S=PARP(15)**2
11002         PS=VINT(3)**2
11003         Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11004      &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11005         Q2INT=SQRT(Q0S*Q2EFF)
11006         Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11007       ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11008         Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11009       ENDIF
11010       IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11011         Q0S=PARP(15)**2
11012         PS=VINT(4)**2
11013         Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11014      &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11015         Q2INT=SQRT(Q0S*Q2EFF)
11016         Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11017       ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11018         Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11019       ENDIF
11020       MCEV=0
11021       ALAMS=PARU(112)
11022       PARU(112)=PARP(61)
11023       FQ2C=1D0
11024       TCMX=0D0
11025       IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11026         MCEV=1
11027         IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11028         IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11029         TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11030         IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11031      &  MCEV=0
11032       ENDIF
11033
11034 C...Initialize QED evolution and check phase space.
11035       MEEV=0
11036       XEE=1D-10
11037       SPME=PMAS(11,1)**2
11038       IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11039      &SPME=PMAS(13,1)**2
11040       IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11041      &SPME=PMAS(15,1)**2
11042       Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11043       TEMX=0D0
11044       FWTE=10D0
11045       IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11046         MEEV=1
11047         TEMX=LOG(Q2MX/SPME)
11048         IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11049       ENDIF
11050       IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11051         MEEV=2
11052         TEMX=TCMX
11053         FWTE=1D0
11054       ENDIF
11055       IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11056
11057 C...Loopback point in case of failure to reconstruct kinematics.
11058       NS=N
11059       LOOP=0
11060   100 LOOP=LOOP+1
11061       IF(LOOP.GT.100) THEN
11062         MINT(51)=1
11063         RETURN
11064       ENDIF
11065       N=NS
11066
11067 C...Initial values: flavours, momenta, virtualities.
11068       DO 120 JT=1,2
11069         MORE(JT)=1
11070         KFBEAM(JT)=MINT(10+JT)
11071         IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11072         KFLS(JT)=MINT(14+JT)
11073         KFLS(JT+2)=KFLS(JT)
11074         XS(JT)=VINT(40+JT)
11075         IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11076         ZS(JT)=1D0
11077         Q2S(JT)=FCQ2MX*Q2MX
11078         DQ2(JT)=0D0
11079         TEVCSV(JT)=TCMX
11080         ALAM(JT)=PARP(61)
11081         THE2(JT)=1D0
11082         TEVESV(JT)=TEMX
11083         MCESV(JT)=0
11084 C...Calculate initial parton distribution weights.
11085         MINT(105)=MINT(102+JT)
11086         MINT(109)=MINT(106+JT)
11087         VINT(120)=VINT(2+JT)
11088 C.... ALICE
11089 C.... Store side in MINT(124)
11090         MINT(124) = JT
11091         IF(XS(JT).LT.1D0-XEE) THEN
11092           IF(MSTP(57).LE.1) THEN
11093             CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11094           ELSE
11095             CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11096           ENDIF
11097         ENDIF
11098         DO 110 KFL=-25,25
11099           XFS(JT,KFL)=XFB(KFL)
11100   110   CONTINUE
11101 C...Special kinematics check for c/b quarks (that g -> c cbar or
11102 C...b bbar kinematically possible).
11103       KFLCB=IABS(KFLS(JT))
11104       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11105         IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11106           MINT(51)=1
11107           RETURN
11108         ENDIF
11109       ENDIF
11110   120 CONTINUE
11111       DSH=VINT(44)
11112       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11113
11114 C...Find if interference with final state partons.
11115       MFIS=0
11116       IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11117       IF(MFIS.NE.0) THEN
11118         DO 140 I=1,2
11119           KCFI(I)=0
11120           KCA=PYCOMP(IABS(KFLS(I)))
11121           IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11122           NFIS(I)=0
11123           IF(KCFI(I).NE.0) THEN
11124             IF(I.EQ.1) IPFS=IPUS1
11125             IF(I.EQ.2) IPFS=IPUS2
11126             DO 130 J=1,2
11127               ICSI=MOD(K(IPFS,3+J),MSTU(5))
11128               IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11129      &        (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11130                 NFIS(I)=NFIS(I)+1
11131                 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11132      &          P(ICSI,2)**2))
11133                 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11134               ENDIF
11135   130       CONTINUE
11136           ENDIF
11137   140   CONTINUE
11138         IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11139       ENDIF
11140
11141 C...Pick up leg with highest virtuality.
11142       JTOLD=1
11143   150 N=N+1
11144       JT=1
11145       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11146       IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11147       IF(MORE(JT).EQ.0) JT=3-JT
11148       JTOLD=JT
11149       KFLB=KFLS(JT)
11150       XB=XS(JT)
11151       DO 160 KFL=-25,25
11152         XFB(KFL)=XFS(JT,KFL)
11153   160 CONTINUE
11154       DSHR=2D0*SQRT(DSH)
11155       DSHZ=DSH/ZS(JT)
11156
11157 C...Check if allowed to branch.
11158       MCEV=0
11159       IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11160         MCEV=1
11161         XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11162         IF(XB.GE.1D0-2D0*XEC) MCEV=0
11163       ENDIF
11164       MEEV=0
11165       IF(MINT(44+JT).EQ.3) THEN
11166         MEEV=1
11167         IF(XB.GE.1D0-2D0*XEE) MEEV=0
11168         IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11169      &  MEEV=0
11170 C***Currently kill QED shower for resolved photoproduction.
11171         IF(MINT(18+JT).EQ.1) MEEV=0
11172 C***Currently kill shower for W inside electron.
11173         IF(IABS(KFLB).EQ.24) THEN
11174           MCEV=0
11175           MEEV=0
11176         ENDIF
11177       ENDIF
11178       IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11179      &MEEV=2
11180       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11181         Q2B=0D0
11182         GOTO 260
11183       ENDIF
11184
11185 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11186       Q2B=Q2S(JT)
11187       TEVCB=TEVCSV(JT)
11188       TEVEB=TEVESV(JT)
11189       IF(MSTP(62).LE.1) THEN
11190         IF(ZS(JT).GT.0.99999D0) THEN
11191           Q2B=Q2S(JT)
11192         ELSE
11193           Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11194      &    (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11195      &    8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11196         ENDIF
11197         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11198         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11199       ENDIF
11200       IF(MCEV.EQ.1) THEN
11201         ALSDUM=PYALPS(FQ2C*Q2B)
11202         TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11203         ALAM(JT)=PARU(117)
11204         B0=(33D0-2D0*MSTU(118))/6D0
11205       ENDIF
11206       IF(MEEV.EQ.2) TEVEB=TEVCB
11207       TEVCBS=TEVCB
11208       TEVEBS=TEVEB
11209
11210 C...Select side for interference with final state partons.
11211       IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11212         IFI=N-NS
11213         ISFI(IFI)=0
11214         IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11215           ISFI(IFI)=1
11216         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11217           IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11218         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11219           ISFI(IFI)=1
11220           IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11221         ENDIF
11222       ENDIF
11223
11224 C...Calculate preweighting factor for ME-corrected processes.
11225       IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11226
11227 C...Calculate Altarelli-Parisi weights.
11228       DO 170 KFL=-25,25
11229         WTAPC(KFL)=0D0
11230         WTAPE(KFL)=0D0
11231         WTSF(KFL)=0D0
11232   170 CONTINUE
11233 C...q -> q (g or gamma emission), g -> q.
11234       IF(IABS(KFLB).LE.10) THEN
11235         WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11236         WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11237         EQ2=1D0/9D0
11238         IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11239         IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11240      &  (XEC*(1D0-XEC)))
11241         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11242           WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11243           WTAPC(21)=WTGF*WTAPC(21)
11244           WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11245         ENDIF
11246 C...f -> f, gamma -> f.
11247       ELSEIF(IABS(KFLB).LE.20) THEN
11248         WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11249         WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11250         WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11251         IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11252         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11253           WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11254           WTAPE(22)=WTGF*WTAPE(22)
11255         ENDIF
11256 C...f -> g, g -> g.
11257       ELSEIF(KFLB.EQ.21) THEN
11258         WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11259         DO 180 KFL=1,MSTP(58)
11260           WTAPC(KFL)=WTAPQ
11261           WTAPC(-KFL)=WTAPQ
11262   180   CONTINUE
11263         WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11264         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11265           DO 190 KFL=1,MSTP(58)
11266             WTAPC(KFL)=WTFG*WTAPC(KFL)
11267             WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11268   190     CONTINUE
11269           WTAPC(21)=WTGG*WTAPC(21)
11270         ENDIF
11271 C...f -> gamma, W+, W-.
11272       ELSEIF(KFLB.EQ.22) THEN
11273         WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11274         WTAPE(11)=WTAPF
11275         WTAPE(-11)=WTAPF
11276         IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11277           WTAPE(11)=WTFG*WTAPE(11)
11278           WTAPE(-11)=WTFG*WTAPE(-11)
11279         ENDIF
11280       ELSEIF(KFLB.EQ.24) THEN
11281         WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11282      &  (XEE*(XB+XEE)))/XB
11283       ELSEIF(KFLB.EQ.-24) THEN
11284         WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11285      &  (XEE*(XB+XEE)))/XB
11286       ENDIF
11287
11288 C...Calculate parton distribution weights and sum.
11289       NTRY=0
11290   200 NTRY=NTRY+1
11291       IF(NTRY.GT.500) THEN
11292         MINT(51)=1
11293         RETURN
11294       ENDIF
11295       WTSUMC=0D0
11296       WTSUME=0D0
11297       XFBO=MAX(1D-10,XFB(KFLB))
11298       DO 210 KFL=-25,25
11299         WTSF(KFL)=XFB(KFL)/XFBO
11300         WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11301         WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11302   210 CONTINUE
11303       WTSUMC=MAX(0.0001D0,WTSUMC)
11304       WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11305
11306 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11307       NTRY2=0
11308   220 NTRY2=NTRY2+1
11309       IF(NTRY2.GT.500) THEN
11310         MINT(51)=1
11311         RETURN
11312       ENDIF
11313       IF(MCEV.EQ.1) THEN
11314         IF(MSTP(64).LE.0) THEN
11315           TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11316         ELSEIF(MSTP(64).EQ.1) THEN
11317           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11318         ELSE
11319           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11320         ENDIF
11321       ENDIF
11322       IF(MEEV.EQ.1) THEN
11323         TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11324      &  (PARU(101)*FWTE*WTSUME*TEMX)))
11325       ELSEIF(MEEV.EQ.2) THEN
11326         TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11327       ENDIF
11328
11329 C...Translate t into Q2 scale; choose between QCD and QED evolution.
11330   230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11331       IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11332       IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11333 C...Ensure that Q2 is above threshold for charm/bottom.
11334       KFLCB=IABS(KFLB)
11335       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11336      &MCEV.EQ.1) THEN
11337         IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11338           Q2CB=1.1D0*PMAS(KFLCB,1)**2
11339           TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11340           FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11341         ENDIF
11342       ENDIF
11343       IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11344      &MEEV.EQ.2) THEN
11345         IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11346       ENDIF
11347       MCE=0
11348       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11349       ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11350         IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11351       ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11352         IF(Q2EB.GT.Q2MNE) MCE=2
11353       ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11354         IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11355       ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11356         IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11357         IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11358       ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11359         MCE=1
11360         IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11361         IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11362       ELSE
11363         MCE=2
11364         IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11365         IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11366       ENDIF
11367
11368 C...Evolution possibly ended. Update t values.
11369       IF(MCE.EQ.0) THEN
11370         Q2B=0D0
11371         GOTO 260
11372       ELSEIF(MCE.EQ.1) THEN
11373         Q2B=Q2CB
11374         Q2REF=FQ2C*Q2B
11375         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11376         IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11377       ELSE
11378         Q2B=Q2EB
11379         Q2REF=Q2B
11380         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11381       ENDIF
11382
11383 C...Select flavour for branching parton.
11384       IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11385       IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11386       KFLA=-25
11387   240 KFLA=KFLA+1
11388       IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11389       IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11390       IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11391       IF(KFLA.EQ.25) THEN
11392         Q2B=0D0
11393         GOTO 260
11394       ENDIF
11395
11396 C...Choose z value and corrective weight.
11397       WTZ=0D0
11398 C...q -> q + g or q -> q + gamma.
11399       IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11400         Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11401      &  (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11402         WTZ=0.5D0*(1D0+Z**2)
11403 C...q -> g + q.
11404       ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11405         Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11406         WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11407 C...f -> f + gamma.
11408       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11409         IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11410           Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11411      &    (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11412         ELSE
11413           Z=XB+XB*(XEE/(1D0-XEE))*
11414      &    ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11415         ENDIF
11416         WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11417 C...f -> gamma + f.
11418       ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11419         Z=XB+XB*(XEE/(1D0-XEE))*
11420      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11421         WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11422 C...f -> W+- + f.
11423       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11424         Z=XB+XB*(XEE/(1D0-XEE))*
11425      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11426         WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11427      &  (Q2B/(Q2B+PMAS(24,1)**2))
11428 C...g -> q + qbar.
11429       ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11430         Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11431         WTZ=1D0-2D0*Z*(1D0-Z)
11432 C...g -> g + g.
11433       ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11434         Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11435         WTZ=(1D0-Z*(1D0-Z))**2
11436 C...gamma -> f + fbar.
11437       ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11438         Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11439         WTZ=1D0-2D0*Z*(1D0-Z)
11440       ENDIF
11441       IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11442
11443 C...Option with resummation of soft gluon emission as effective z shift.
11444       IF(MCE.EQ.1) THEN
11445         IF(MSTP(65).GE.1) THEN
11446           RSOFT=6D0
11447           IF(KFLB.NE.21) RSOFT=8D0/3D0
11448           Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11449           IF(Z.LE.XB) GOTO 220
11450         ENDIF
11451
11452 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11453         IF(MSTP(64).GE.2) THEN
11454           IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11455           ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11456           IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11457           IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11458         ENDIF
11459       ENDIF
11460
11461 C...Remove kinematically impossible branchings.
11462       UHAT=Q2B-DSH*(1D0-Z)/Z
11463       IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11464
11465 C...Select phi angle of branching at random.
11466       PHIBR=PARU(2)*PYR(0)
11467
11468 C...Matrix-element corrections for some processes.
11469       IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11470         IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11471           CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11472           WTZ=WTZ*WTME/WTFF
11473         ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11474           CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11475           WTZ=WTZ*WTME/WTGF
11476         ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11477           CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11478           WTZ=WTZ*WTME/WTFG
11479         ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11480           CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11481           WTZ=WTZ*WTME/WTGG
11482         ENDIF
11483       ENDIF
11484
11485 C...Impose angular constraint in first branching from interference
11486 C...with final state partons.
11487       IF(MCE.EQ.1) THEN
11488         IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11489           THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11490           IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11491             IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11492           ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11493             IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11494           ENDIF
11495         ENDIF
11496
11497 C...Option with angular ordering requirement.
11498         IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11499           THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11500           IF(THE2T.GT.THE2(JT)) GOTO 220
11501         ENDIF
11502       ENDIF
11503
11504 C...Weighting with new parton distributions.
11505       MINT(105)=MINT(102+JT)
11506       MINT(109)=MINT(106+JT)
11507       VINT(120)=VINT(2+JT)
11508 C.... ALICE
11509 C.... Store side in MINT(124)
11510       MINT(124)=JT
11511
11512       IF(MSTP(57).LE.1) THEN
11513         CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11514       ELSE
11515         CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11516       ENDIF
11517       XFBN=XFN(KFLB)
11518       IF(XFBN.LT.1D-20) THEN
11519         IF(KFLA.EQ.KFLB) THEN
11520           TEVCB=TEVCBS
11521           TEVEB=TEVEBS
11522           WTAPC(KFLB)=0D0
11523           WTAPE(KFLB)=0D0
11524           GOTO 200
11525         ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11526           TEVCB=0.5D0*(TEVCBS+TEVCB)
11527           GOTO 230
11528         ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11529           TEVEB=0.5D0*(TEVEBS+TEVEB)
11530           GOTO 230
11531         ELSE
11532           XFBN=1D-10
11533           XFN(KFLB)=XFBN
11534         ENDIF
11535       ENDIF
11536       DO 250 KFL=-25,25
11537         XFB(KFL)=XFN(KFL)
11538   250 CONTINUE
11539       XA=XB/Z
11540 C.... ALICE
11541 C.... Store side in MINT(124)
11542       MINT(124) = JT
11543 C....
11544
11545       IF(MSTP(57).LE.1) THEN
11546         CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11547       ELSE
11548         CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11549       ENDIF
11550       XFAN=XFA(KFLA)
11551       IF(XFAN.LT.1D-20) GOTO 200
11552       WTSFA=WTSF(KFLA)
11553       IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11554
11555 C...Define two hard scatterers in their CM-frame.
11556   260 IF(N.EQ.NS+2) THEN
11557         DQ2(JT)=Q2B
11558         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11559         DO 280 JR=1,2
11560           I=NS+JR
11561           IF(JR.EQ.1) IPO=IPUS1
11562           IF(JR.EQ.2) IPO=IPUS2
11563           DO 270 J=1,5
11564             K(I,J)=0
11565             P(I,J)=0D0
11566             V(I,J)=0D0
11567   270     CONTINUE
11568           K(I,1)=14
11569           K(I,2)=KFLS(JR+2)
11570           K(I,4)=IPO
11571           K(I,5)=IPO
11572           P(I,3)=DPLCM*(-1)**(JR+1)
11573           P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11574           P(I,5)=-SQRT(DQ2(JR))
11575           K(IPO,1)=14
11576           K(IPO,3)=I
11577           K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11578           K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11579   280   CONTINUE
11580
11581 C...Find maximum allowed mass of timelike parton.
11582       ELSEIF(N.GT.NS+2) THEN
11583         JR=3-JT
11584         DQ2(3)=Q2B
11585         DPC(1)=P(IS(1),4)
11586         DPC(2)=P(IS(2),4)
11587         DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11588         DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11589         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11590         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11591         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11592         IKIN=0
11593         IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11594      &  1D-10*DPD(1)) IKIN=1
11595         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11596      &  (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11597         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11598      &  (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11599
11600 C...Generate timelike parton shower (if required).
11601         IT=N
11602         DO 290 J=1,5
11603           K(IT,J)=0
11604           P(IT,J)=0D0
11605           V(IT,J)=0D0
11606   290   CONTINUE
11607 C...f -> f + g (gamma).
11608         IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11609           K(IT,2)=21
11610           IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11611 C...f -> g (gamma, W+-) + f.
11612         ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11613           K(IT,2)=KFLB
11614           IF(KFLS(JT+2).EQ.24) THEN
11615             K(IT,2)=-12
11616           ELSEIF(KFLS(JT+2).EQ.-24) THEN
11617             K(IT,2)=12
11618           ENDIF
11619 C...g (gamma) -> f + fbar, g + g.
11620         ELSE
11621           K(IT,2)=-KFLS(JT+2)
11622           IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11623         ENDIF
11624         K(IT,1)=3
11625         IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11626      &  IABS(K(IT,2)).EQ.22) K(IT,1)=1
11627         P(IT,5)=PYMASS(K(IT,2))
11628         IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11629         IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11630           MSTJ48=MSTJ(48)
11631           PARJ85=PARJ(85)
11632           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11633           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11634           IF(MSTP(63).EQ.1) THEN
11635             Q2TIM=DMSMA
11636           ELSEIF(MSTP(63).EQ.2) THEN
11637             Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11638           ELSE
11639             Q2TIM=DMSMA
11640             MSTJ(48)=1
11641             IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11642             IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11643      &      DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11644             PARJ(85)=SQRT(MAX(0D0,DPT2))*
11645      &      (1D0/P(IT,4)+1D0/P(IS(JT),4))
11646           ENDIF
11647           CALL PYSHOW(IT,0,SQRT(Q2TIM))
11648           MSTJ(48)=MSTJ48
11649           PARJ(85)=PARJ85
11650           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11651         ENDIF
11652
11653 C...Reconstruct kinematics of branching: timelike parton shower.
11654         DMS=P(IT,5)**2
11655         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11656         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11657      &  0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11658      &  (4D0*DSH*DPC(3)**2)
11659         IF(DPT2.LT.0D0) GOTO 100
11660         DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11661      &  DSHR)/DPC(3)-DPC(3)
11662         P(IT,1)=SQRT(DPT2)
11663         P(IT,3)=DPB(1)*(-1)**(JT+1)
11664         P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11665         IF(N.GE.IT+1) THEN
11666           DPB(1)=SQRT(DPB(1)**2+DPT2)
11667           DPB(2)=SQRT(DPB(1)**2+DMS)
11668           DPB(3)=P(IT+1,3)
11669           DPB(4)=SQRT(DPB(3)**2+DMS)
11670           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11671      &    DPB(1))
11672           CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11673           THE=PYANGL(P(IT,3),P(IT,1))
11674           CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11675         ENDIF
11676
11677 C...Reconstruct kinematics of branching: spacelike parton.
11678         DO 300 J=1,5
11679           K(N+1,J)=0
11680           P(N+1,J)=0D0
11681           V(N+1,J)=0D0
11682   300   CONTINUE
11683         K(N+1,1)=14
11684         K(N+1,2)=KFLB
11685         P(N+1,1)=P(IT,1)
11686         P(N+1,3)=P(IT,3)+P(IS(JT),3)
11687         P(N+1,4)=P(IT,4)+P(IS(JT),4)
11688         P(N+1,5)=-SQRT(DQ2(3))
11689
11690 C...Define colour flow of branching.
11691         K(IS(JT),3)=N+1
11692         K(IT,3)=N+1
11693         IM1=N+1
11694         IM2=N+1
11695 C...f -> f + gamma (Z, W).
11696         IF(IABS(K(IT,2)).GE.22) THEN
11697           K(IT,1)=1
11698           ID1=IS(JT)
11699           ID2=IS(JT)
11700 C...f -> gamma (Z, W) + f.
11701         ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11702           ID1=IT
11703           ID2=IT
11704 C...gamma -> q + qbar, g + g.
11705         ELSEIF(K(N+1,2).EQ.22) THEN
11706           ID1=IS(JT)
11707           ID2=IT
11708           IM1=ID2
11709           IM2=ID1
11710 C...q -> q + g.
11711         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11712           ID1=IT
11713           ID2=IS(JT)
11714 C...q -> g + q.
11715         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11716           ID1=IS(JT)
11717           ID2=IT
11718 C...qbar -> qbar + g.
11719         ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11720           ID1=IS(JT)
11721           ID2=IT
11722 C...qbar -> g + qbar.
11723         ELSEIF(K(N+1,2).LT.0) THEN
11724           ID1=IT
11725           ID2=IS(JT)
11726 C...g -> g + g; g -> q + qbar.
11727         ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11728           ID1=IS(JT)
11729           ID2=IT
11730         ELSE
11731           ID1=IT
11732           ID2=IS(JT)
11733         ENDIF
11734         IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11735         IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11736         K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11737         K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11738         IF(ID1.NE.ID2) THEN
11739           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11740           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11741         ENDIF
11742         N=N+1
11743
11744 C...Boost to new CM-frame.
11745         DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11746         DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11747         IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11748         CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11749         IR=N+(JT-1)*(IS(1)-N)
11750         CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11751      &  0D0,0D0,0D0)
11752       ENDIF
11753
11754 C...Update kinematics variables.
11755       IS(JT)=N
11756       DQ2(JT)=Q2B
11757       IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11758       DSH=DSHZ
11759
11760 C...Save quantities; loop back.
11761       Q2S(JT)=Q2B
11762       DPHI(JT)=PHIBR
11763       MCESV(JT)=MCE
11764       IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11765      &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11766         KFLS(JT+2)=KFLS(JT)
11767         KFLS(JT)=KFLA
11768         XS(JT)=XA
11769         ZS(JT)=Z
11770         DO 310 KFL=-25,25
11771           XFS(JT,KFL)=XFA(KFL)
11772   310   CONTINUE
11773         TEVCSV(JT)=TEVCB
11774         TEVESV(JT)=TEVEB
11775       ELSE
11776         MORE(JT)=0
11777         IF(JT.EQ.1) IPU1=N
11778         IF(JT.EQ.2) IPU2=N
11779       ENDIF
11780       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11781         CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11782         IF(MSTU(21).GE.1) N=NS
11783         IF(MSTU(21).GE.1) RETURN
11784       ENDIF
11785       IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11786
11787 C...Boost hard scattering partons to frame of shower initiators.
11788       DO 320 J=1,3
11789         ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11790   320 CONTINUE
11791       K(N+2,1)=1
11792       DO 330 J=1,5
11793         P(N+2,J)=P(NS+1,J)
11794   330 CONTINUE
11795       CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11796       ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11797       ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11798       CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11799       CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11800      &ROBO(5))
11801
11802 C...Store user information. Reset Lambda value.
11803       K(IPU1,3)=MINT(83)+3
11804       K(IPU2,3)=MINT(83)+4
11805       DO 340 JT=1,2
11806         MINT(12+JT)=KFLS(JT)
11807         VINT(140+JT)=XS(JT)
11808         IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
11809   340 CONTINUE
11810       PARU(112)=ALAMS
11811
11812       RETURN
11813       END
11814
11815 C*********************************************************************
11816
11817 C...PYMEMX
11818 C...Generates maximum ME weight in some initial-state showers.
11819 C...Inparameter MECOR: kind of hard scattering process
11820 C...Outparameter WTFF: maximum weight for fermion -> fermion
11821 C...             WTGF: maximum weight for gluon/photon -> fermion
11822 C...             WTFG: maximum weight for fermion -> gluon/photon
11823 C...             WTGG: maximum weight for gluon -> gluon
11824
11825       SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11826
11827 C...Double precision and integer declarations.
11828       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11829       IMPLICIT INTEGER(I-N)
11830       INTEGER PYK,PYCHGE,PYCOMP
11831 C...Commonblocks.
11832       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11833       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11834       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11835       COMMON/PYINT1/MINT(400),VINT(400)
11836       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11837       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11838
11839 C...Default maximum weight.
11840       WTFF=1D0
11841       WTGF=1D0
11842       WTFG=1D0
11843       WTGG=1D0
11844
11845 C...Select maximum weight by process.
11846       IF(MECOR.EQ.1) THEN
11847         WTFF=1D0
11848         WTGF=3D0
11849       ELSEIF(MECOR.EQ.2) THEN
11850         WTFG=1D0
11851         WTGG=1D0
11852       ENDIF
11853
11854       RETURN
11855       END
11856
11857 C*********************************************************************
11858
11859 C...PYMEWT
11860 C...Calculates actual ME weight in some initial-state showers.
11861 C...Inparameter MECOR: kind of hard scattering process
11862 C...            IFLCB: flavour combination of branching,
11863 C...                   1 for fermion -> fermion,
11864 C...                   2 for gluon/photon -> fermion
11865 C...                   3 for fermion -> gluon/photon,
11866 C...                   4 for gluon -> gluon
11867 C...            Q2:    Q2 value of shower branching
11868 C...            Z:     Z value of branching
11869 C...In+outparameter PHIBR: azimuthal angle of branching
11870 C...Outparameter WTME: actual ME weight
11871
11872       SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
11873
11874 C...Double precision and integer declarations.
11875       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11876       IMPLICIT INTEGER(I-N)
11877       INTEGER PYK,PYCHGE,PYCOMP
11878 C...Commonblocks.
11879       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11880       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11881       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11882       COMMON/PYINT1/MINT(400),VINT(400)
11883       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11884       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11885
11886 C...Default output.
11887       WTME=1D0
11888
11889 C...Define kinematics of shower branching in Mandelstam variables.
11890       SQM=VINT(44)
11891       SH=SQM/Z
11892       TH=-Q2
11893       UH=Q2-SQM*(1D0-Z)/Z
11894
11895 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
11896       IF(MECOR.EQ.1) THEN
11897         IF(IFLCB.EQ.1) THEN
11898           WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
11899         ELSEIF(IFLCB.EQ.2) THEN
11900           WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
11901         ENDIF
11902
11903 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
11904       ELSEIF(MECOR.EQ.2) THEN
11905         IF(IFLCB.EQ.3) THEN
11906           WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
11907         ELSEIF(IFLCB.EQ.4) THEN
11908           WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
11909         ENDIF
11910       ENDIF
11911
11912       RETURN
11913       END
11914
11915 C*********************************************************************
11916
11917 C...PYADSH
11918 C...Administers the generation of successive final-state showers
11919 C...in external processes.
11920
11921       SUBROUTINE PYADSH(NFIN)
11922
11923 C...Double precision and integer declarations.
11924       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11925       IMPLICIT INTEGER(I-N)
11926       INTEGER PYK,PYCHGE,PYCOMP
11927 C...Commonblocks.
11928       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11929       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11930       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11931       COMMON/PYINT1/MINT(400),VINT(400)
11932       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11933 C...Local array.
11934       DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
11935
11936 C...Set primary vertex.
11937       DO 100 J=1,5
11938         V(MINT(83)+5,J)=0D0
11939         V(MINT(83)+6,J)=0D0
11940         V(MINT(84)+1,J)=0D0
11941         V(MINT(84)+2,J)=0D0
11942   100 CONTINUE
11943
11944 C...Isolate systems of particles with the same mother.
11945       NSYS=0
11946       IMS=-1
11947       DO 140 I=MINT(84)+3,NFIN
11948         IM=K(I,3)
11949         IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
11950         IF(IM.NE.IMS) THEN
11951           NSYS=NSYS+1
11952           IBEG(NSYS)=I
11953           IMS=IM
11954         ENDIF
11955
11956 C...Set production vertices.
11957         IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
11958      &  THEN
11959           DO 110 J=1,4
11960             V(I,J)=0D0
11961   110     CONTINUE
11962         ELSE
11963           DO 120 J=1,4
11964             V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
11965   120     CONTINUE
11966         ENDIF
11967         IF(MSTP(125).GE.1) THEN
11968           IDOC=I-MSTP(126)+4
11969           DO 130 J=1,5
11970             V(IDOC,J)=V(I,J)
11971   130     CONTINUE
11972         ENDIF
11973   140 CONTINUE
11974
11975 C...End loop over systems. Return if no showers to be performed.
11976       IBEG(NSYS+1)=NFIN+1
11977       IF(MSTP(71).LE.0) RETURN
11978
11979 C...Loop through systems of particles; check that sensible size.
11980       DO 260 ISYS=1,NSYS
11981         NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
11982         IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
11983         ELSEIF(NSIZ.LE.1) THEN
11984           CALL PYERRM(2,'(PYADSH:) only one particle in system')
11985         ELSEIF(NSIZ.GT.7) THEN
11986           CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
11987         ELSE
11988
11989 C...Save status codes and daughters of showering pair; reset them.
11990           DO 150 J=1,4
11991             PSUM(J)=0D0
11992   150     CONTINUE
11993           DO 170 II=1,NSIZ
11994             I=IBEG(ISYS)-1+II
11995             KSAV(II,1)=K(I,1)
11996             IF(K(I,1).GT.10) THEN
11997               K(I,1)=1
11998               IF(KSAV(II,1).EQ.14) K(I,1)=3
11999             ENDIF
12000             IF(KSAV(II,1).LE.10) THEN
12001             ELSEIF(K(I,1).EQ.1) THEN
12002               KSAV(II,4)=K(I,4)
12003               KSAV(II,5)=K(I,5)
12004               K(I,4)=0
12005               K(I,5)=0
12006             ELSE
12007               KSAV(II,4)=MOD(K(I,4),MSTU(5))
12008               KSAV(II,5)=MOD(K(I,5),MSTU(5))
12009               K(I,4)=K(I,4)-KSAV(II,4)
12010               K(I,5)=K(I,5)-KSAV(II,5)
12011             ENDIF
12012             DO 160 J=1,4
12013               PSUM(J)=PSUM(J)+P(I,J)
12014   160       CONTINUE
12015   170     CONTINUE
12016
12017 C...Perform shower.
12018           QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12019      &    PSUM(3)**2))
12020           IF(ISYS.EQ.1) QMAX=VINT(55)
12021           NSAV=N
12022           IF(NSIZ.EQ.2) THEN
12023             CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12024           ELSE
12025             CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12026           ENDIF
12027
12028 C...Look up showered copies of original showering particles.
12029           DO 250 II=1,NSIZ
12030             I=IBEG(ISYS)-1+II
12031             IMV=I
12032             IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12033             ELSEIF(K(I,1).EQ.11) THEN
12034   180         IMV=MOD(K(IMV,4),MSTU(5))
12035               IF(K(IMV,1).EQ.11) GOTO 180
12036             ELSE
12037               KDA1=MOD(K(I,4),MSTU(5))
12038               KDA2=MOD(K(I,5),MSTU(5))
12039               DO 190 I3=I+1,N
12040                 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12041      &          THEN
12042                   IMV=I3
12043                   KDA1=MOD(K(I3,4),MSTU(5))
12044                   KDA2=MOD(K(I3,5),MSTU(5))
12045                 ENDIF
12046   190         CONTINUE
12047             ENDIF
12048
12049 C...Restore daughter info of original partons to showered copies.
12050             IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12051             IF(KSAV(II,1).LE.10) THEN
12052             ELSEIF(K(I,1).EQ.1) THEN
12053               K(IMV,4)=KSAV(II,4)
12054               K(IMV,5)=KSAV(II,5)
12055             ELSE
12056               K(IMV,4)=K(IMV,4)+KSAV(II,4)
12057               K(IMV,5)=K(IMV,5)+KSAV(II,5)
12058             ENDIF
12059
12060 C...Reset mother info of existing daughters to showered copies.
12061             DO 200 I3=IBEG(ISYS+1),NFIN
12062               IF(K(I3,3).EQ.I) K(I3,3)=IMV
12063               IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12064                 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12065                 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12066               ENDIF
12067   200       CONTINUE
12068
12069 C...Boost all original daughters to new frame of showered copy.
12070             IF(IMV.NE.I) THEN
12071               DO 210 J=1,3
12072                 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12073   210         CONTINUE
12074               FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12075               DO 220 J=1,3
12076                 BETA(J)=FAC*BETA(J)
12077   220         CONTINUE
12078               DO 240 I3=IBEG(ISYS+1),NFIN
12079                 IMO=I3
12080   230           IMO=K(IMO,3)
12081                 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12082                 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12083      &          CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12084   240         CONTINUE
12085             ENDIF
12086   250     CONTINUE
12087
12088 C...End of loop over showering systems
12089         ENDIF
12090   260 CONTINUE
12091
12092       RETURN
12093       END
12094
12095 C*********************************************************************
12096
12097 C...PYRESD
12098 C...Allows resonances to decay (including parton showers for hadronic
12099 C...channels).
12100
12101       SUBROUTINE PYRESD(IRES)
12102
12103 C...Double precision and integer declarations.
12104       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12105       IMPLICIT INTEGER(I-N)
12106       INTEGER PYK,PYCHGE,PYCOMP
12107 C...Parameter statement to help give large particle numbers.
12108       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12109      &KEXCIT=4000000,KDIMEN=5000000)
12110 C...Commonblocks.
12111       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12112       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12113       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12114       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12115       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12116       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12117       COMMON/PYINT1/MINT(400),VINT(400)
12118       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12119       COMMON/PYINT4/MWID(500),WIDS(500,5)
12120       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12121      &/PYINT1/,/PYINT2/,/PYINT4/
12122 C...Local arrays and complex and character variables.
12123       DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12124      &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12125      &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12126      &PHI(3),WDTP(0:300),WDTE(0:300,0:5),DPMO(5),XM(5),VDCY(4)
12127       COMPLEX FGK,HA(6,6),HC(6,6)
12128       REAL TIR,UIR
12129       CHARACTER CODE*9,MASS*9
12130
12131 C...The F, Xi and Xj functions of Gunion and Kunszt
12132 C...(Phys. Rev. D33, 665, plus errata from the authors).
12133       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12134      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12135       DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12136      &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12137       DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12138      &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12139      &2D0*(D34/D56+D56/D34))
12140
12141 C...Some general constants.
12142       XW=PARU(102)
12143       XWV=XW
12144       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12145       XW1=1D0-XW
12146       SQMZ=PMAS(23,1)**2
12147       GMMZ=PMAS(23,1)*PMAS(23,2)
12148       SQMW=PMAS(24,1)**2
12149       GMMW=PMAS(24,1)*PMAS(24,2)
12150       SH=VINT(44)
12151
12152 C...Boost and rotate to rest frame of incoming partons,
12153 C...to get proper amount of smearing of decay angles.
12154       IBST=0
12155       IF(IRES.EQ.0) THEN
12156         IBST=1
12157         ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12158         BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12159         BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12160         BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12161         CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12162         PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12163         CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12164         THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12165         CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12166       ENDIF
12167
12168 C...Reset original resonance configuration.
12169       DO 100 JT=1,8
12170         IREF(1,JT)=0
12171   100 CONTINUE
12172
12173 C...Define initial one, two or three objects for subprocess.
12174       IHDEC=0
12175       IF(IRES.EQ.0) THEN
12176         ISUB=MINT(1)
12177         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12178           IREF(1,1)=MINT(84)+2+ISET(ISUB)
12179           IREF(1,4)=MINT(83)+6+ISET(ISUB)
12180           JTMAX=1
12181         ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12182           IREF(1,1)=MINT(84)+1+ISET(ISUB)
12183           IREF(1,2)=MINT(84)+2+ISET(ISUB)
12184           IREF(1,4)=MINT(83)+5+ISET(ISUB)
12185           IREF(1,5)=MINT(83)+6+ISET(ISUB)
12186           JTMAX=2
12187         ELSEIF(ISET(ISUB).EQ.5) THEN
12188           IREF(1,1)=MINT(84)+3
12189           IREF(1,2)=MINT(84)+4
12190           IREF(1,3)=MINT(84)+5
12191           IREF(1,4)=MINT(83)+7
12192           IREF(1,5)=MINT(83)+8
12193           IREF(1,6)=MINT(83)+9
12194           JTMAX=3
12195         ENDIF
12196
12197 C...Define original resonance for odd cases.
12198       ELSE
12199         ISUB=0
12200         IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12201      &  IHDEC=1
12202         IF(IHDEC.EQ.1) ISUB=3
12203         IREF(1,1)=IRES
12204         IREF(1,4)=K(IRES,3)
12205         JTMAX=1
12206       ENDIF
12207
12208 C...Check if initial resonance has been moved (in resonance + jet).
12209       DO 120 JT=1,3
12210         IF(IREF(1,JT).GT.0) THEN
12211           IF(K(IREF(1,JT),1).GT.10) THEN
12212             KFA=IABS(K(IREF(1,JT),2))
12213             IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12214               KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12215               KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12216               DO 110 I=IREF(1,JT)+1,N
12217                 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12218      &          I.EQ.KDA2)) THEN
12219                   IREF(1,JT)=I
12220                   KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12221                   KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12222                 ENDIF
12223   110         CONTINUE
12224             ELSE
12225               KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12226               IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12227             ENDIF
12228           ENDIF
12229         ENDIF
12230   120 CONTINUE
12231
12232 C.....Set decay vertex for initial resonances
12233       DO 140 JT=1,JTMAX
12234         DO 130 I=1,4
12235           V(IREF(1,JT),I)=0D0
12236   130   CONTINUE
12237   140 CONTINUE
12238
12239 C...Loop over decay history.
12240       NP=1
12241       IP=0
12242   150 IP=IP+1
12243       NINH=0
12244       JTMAX=2
12245       IF(IREF(IP,2).EQ.0) JTMAX=1
12246       IF(IREF(IP,3).NE.0) JTMAX=3
12247       IT4=0
12248       NSAV=N
12249
12250 C...Start treatment of one, two or three resonances in parallel.
12251   160 N=NSAV
12252       DO 250 JT=1,JTMAX
12253         ID=IREF(IP,JT)
12254         KDCY(JT)=0
12255         KFL1(JT)=0
12256         KFL2(JT)=0
12257         KFL3(JT)=0
12258         KEQL(JT)=0
12259         NSD(JT)=ID
12260
12261 C...Check whether particle can/is allowed to decay.
12262         IF(ID.EQ.0) GOTO 240
12263         KFA=IABS(K(ID,2))
12264         KCA=PYCOMP(KFA)
12265         IF(MWID(KCA).EQ.0) GOTO 240
12266         IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
12267         IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12268      &  KFA.EQ.18) IT4=IT4+1
12269         K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12270         K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12271
12272 C...Choose lifetime and determine decay vertex.
12273         IF(K(ID,1).EQ.5) THEN
12274           V(ID,5)=0D0
12275         ELSEIF(K(ID,1).NE.4) THEN
12276           V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12277         ENDIF
12278         DO 170 J=1,4
12279           VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12280   170   CONTINUE
12281
12282 C...Determine whether decay allowed or not.
12283         MOUT=0
12284         IF(MSTJ(22).EQ.2) THEN
12285           IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12286         ELSEIF(MSTJ(22).EQ.3) THEN
12287           IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12288         ELSEIF(MSTJ(22).EQ.4) THEN
12289           IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12290           IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12291         ENDIF
12292         IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12293           K(ID,1)=4
12294           GOTO 240
12295         ENDIF
12296
12297 C...Info for selection of decay channel: sign, pairings.
12298         IF(KCHG(KCA,3).EQ.0) THEN
12299           IPM=2
12300         ELSE
12301           IPM=(5-ISIGN(1,K(ID,2)))/2
12302         ENDIF
12303         KFB=0
12304         IF(JTMAX.EQ.2) THEN
12305           KFB=IABS(K(IREF(IP,3-JT),2))
12306         ELSEIF(JTMAX.EQ.3) THEN
12307           JT2=JT+1-3*(JT/3)
12308           KFB=IABS(K(IREF(IP,JT2),2))
12309           IF(KFB.NE.KFA) THEN
12310             JT2=JT+2-3*((JT+1)/3)
12311             KFB=IABS(K(IREF(IP,JT2),2))
12312           ENDIF
12313         ENDIF
12314
12315 C...Select decay channel.
12316         IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12317      &  ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12318         CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12319         WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12320         IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12321         IF(WDTE0S.LE.0D0) GOTO 240
12322         RKFL=WDTE0S*PYR(0)
12323         IDL=0
12324   180   IDL=IDL+1
12325         IDC=IDL+MDCY(KCA,2)-1
12326         RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12327         IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12328         IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12329
12330 C...Read out flavours and colour charges of decay channel chosen.
12331         KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12332         IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12333         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12334         KFC1A=PYCOMP(IABS(KFL1(JT)))
12335         IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12336         KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12337         IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12338         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12339         KFC2A=PYCOMP(IABS(KFL2(JT)))
12340         IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12341         KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12342         IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12343         KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12344         IF(KFL3(JT).NE.0) THEN
12345           KFC3A=PYCOMP(IABS(KFL3(JT)))
12346           IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12347           KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12348           IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12349         ENDIF
12350
12351 C...Set/save further info on channel.
12352         KDCY(JT)=1
12353         IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12354         NSD(JT)=N
12355         HGZ(JT,1)=VINT(111)
12356         HGZ(JT,2)=VINT(112)
12357         HGZ(JT,3)=VINT(114)
12358         JTZ=JT
12359
12360 C...Select masses; to begin with assume resonances narrow.
12361         DO 200 I=1,3
12362           P(N+I,5)=0D0
12363           PMMN(I)=0D0
12364           IF(I.EQ.1) THEN
12365             KFLW=IABS(KFL1(JT))
12366             KCW=KFC1A
12367           ELSEIF(I.EQ.2) THEN
12368             KFLW=IABS(KFL2(JT))
12369             KCW=KFC2A
12370           ELSEIF(I.EQ.3) THEN
12371             IF(KFL3(JT).EQ.0) GOTO 200
12372             KFLW=IABS(KFL3(JT))
12373             KCW=KFC3A
12374           ENDIF
12375           P(N+I,5)=PMAS(KCW,1)
12376 CMRENNA++
12377 C...This prevents SUSY/t particles from becoming too light.
12378           IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12379             PMMN(I)=PMAS(KCW,1)
12380             DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12381               IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12382                 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12383      &          PMAS(PYCOMP(KFDP(IDC,2)),1)
12384                 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12385      &          PMAS(PYCOMP(KFDP(IDC,3)),1)
12386                 PMMN(I)=MIN(PMMN(I),PMSUM)
12387               ENDIF
12388   190       CONTINUE
12389 CMRENNA--
12390           ELSEIF(KFLW.EQ.6) THEN
12391             PMMN(I)=PMAS(24,1)+PMAS(5,1)
12392           ENDIF
12393   200   CONTINUE
12394
12395 C...Check which two out of three are widest.
12396         IWID1=1
12397         IWID2=2
12398         PWID1=PMAS(KFC1A,2)
12399         PWID2=PMAS(KFC2A,2)
12400         KFLW1=IABS(KFL1(JT))
12401         KFLW2=IABS(KFL2(JT))
12402         IF(KFL3(JT).NE.0) THEN
12403           PWID3=PMAS(KFC3A,2)
12404           IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12405             IWID1=3
12406             PWID1=PWID3
12407             KFLW1=IABS(KFL3(JT))
12408           ELSEIF(PWID3.GT.PWID2) THEN
12409             IWID2=3
12410             PWID2=PWID3
12411             KFLW2=IABS(KFL3(JT))
12412           ENDIF
12413         ENDIF
12414
12415 C...If all narrow then only check that masses consistent.
12416         IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12417      &  PWID2.LT.PARP(41))) THEN
12418 CMRENNA++
12419 C....Handle near degeneracy cases.
12420           IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12421             IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12422               P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12423               IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12424             ENDIF
12425           ENDIF
12426 CMRENNA--
12427           IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12428             CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12429             MINT(51)=1
12430             GOTO 630
12431           ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12432             CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12433             MINT(51)=1
12434             GOTO 630
12435           ENDIF
12436
12437 C...For three wide resonances select narrower of three
12438 C...according to BW decoupled from rest.
12439         ELSE
12440           PMTOT=P(ID,5)
12441           IF(KFL3(JT).NE.0) THEN
12442             IWID3=6-IWID1-IWID2
12443             KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12444      &      KFLW1-KFLW2
12445             LOOP=0
12446   210       LOOP=LOOP+1
12447             P(N+IWID3,5)=PYMASS(KFLW3)
12448             IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12449             PMTOT=PMTOT-P(N+IWID3,5)
12450           ENDIF
12451 C...Select other two correlated within remaining phase space.
12452           IF(IP.EQ.1) THEN
12453             CKIN45=CKIN(45)
12454             CKIN47=CKIN(47)
12455             CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12456             CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12457             CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12458      &      P(N+IWID2,5))
12459             CKIN(45)=CKIN45
12460             CKIN(47)=CKIN47
12461           ELSE
12462             CKIN(49)=PMMN(IWID1)
12463             CKIN(50)=PMMN(IWID2)
12464             CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12465      &      P(N+IWID2,5))
12466             CKIN(49)=0D0
12467             CKIN(50)=0D0
12468           ENDIF
12469           IF(MINT(51).EQ.1) GOTO 630
12470         ENDIF
12471
12472 C...Begin fill decay products, with colour flow for coloured objects.
12473         MSTU10=MSTU(10)
12474         MSTU(10)=1
12475         MSTU(19)=1
12476
12477 CMRENNA++
12478 C...1) Three-body decays of SUSY particles (plus special case top).
12479         IF(KFL3(JT).NE.0) THEN
12480           DO 230 I=N+1,N+3
12481             DO 220 J=1,5
12482               K(I,J)=0
12483 C              V(I,J)=0D0
12484   220       CONTINUE
12485   230     CONTINUE
12486           K(N+1,1)=1
12487           K(N+1,2)=KFL1(JT)
12488           K(N+2,1)=1
12489           K(N+2,2)=KFL2(JT)
12490           K(N+3,1)=1
12491           K(N+3,2)=KFL3(JT)
12492
12493           IDIN=ID
12494           CALL PYTBDY(IDIN)
12495
12496 C...Set colour flow for t -> W + b + Z.
12497           IF(KFA.EQ.6) THEN
12498             K(N+2,1)=3
12499             ISID=4
12500             IF(KCQM(JT).EQ.-1) ISID=5
12501             IDAU=N+2
12502             K(ID,ISID)=K(ID,ISID)+IDAU
12503             K(IDAU,ISID)=MSTU(5)*ID
12504
12505 C...Set colour flow in three-body decays - programmed as special cases.
12506           ELSEIF(KFC2A.LE.6) THEN
12507             K(N+2,1)=3
12508             K(N+3,1)=3
12509             ISID=4
12510             IF(KFL2(JT).LT.0) ISID=5
12511             K(N+2,ISID)=MSTU(5)*(N+3)
12512             K(N+3,9-ISID)=MSTU(5)*(N+2)
12513           ENDIF
12514           IF(KFL1(JT).EQ.KSUSY1+21) THEN
12515             K(N+1,1)=3
12516             K(N+2,1)=3
12517             K(N+3,1)=3
12518             ISID=4
12519             IF(KFL2(JT).LT.0) ISID=5
12520             K(N+1,ISID)=MSTU(5)*(N+2)
12521             K(N+1,9-ISID)=MSTU(5)*(N+3)
12522             K(N+2,ISID)=MSTU(5)*(N+1)
12523             K(N+3,9-ISID)=MSTU(5)*(N+1)
12524           ENDIF
12525           IF(KFA.EQ.KSUSY1+21) THEN
12526             K(N+2,1)=3
12527             K(N+3,1)=3
12528             ISID=4
12529             IF(KFL2(JT).LT.0) ISID=5
12530             K(ID,ISID)=K(ID,ISID)+(N+2)
12531             K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12532             K(N+2,ISID)=MSTU(5)*ID
12533             K(N+3,9-ISID)=MSTU(5)*ID
12534           ENDIF
12535           IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12536      &    IABS(KCQ2(JT)).EQ.1) THEN
12537             K(N+2,1)=3
12538             K(N+3,1)=3
12539             ISID=4
12540             IF(KFL2(JT).LT.0) ISID=5
12541             K(N+2,ISID)=MSTU(5)*(N+3)
12542             K(N+3,9-ISID)=MSTU(5)*(N+2)
12543           ENDIF
12544           N=N+3
12545 CMRENNA--
12546
12547 C...2) Everything else two-body decay.
12548         ELSE
12549           CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12550 C...First set colour flow as if mother colour singlet.
12551           IF(KCQ1(JT).NE.0) THEN
12552             K(N-1,1)=3
12553             IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12554             IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12555           ENDIF
12556           IF(KCQ2(JT).NE.0) THEN
12557             K(N,1)=3
12558             IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12559             IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12560           ENDIF
12561 C...Then redirect colour flow if mother (anti)triplet.
12562           IF(KCQM(JT).EQ.0) THEN
12563           ELSEIF(KCQM(JT).NE.2) THEN
12564             ISID=4
12565             IF(KCQM(JT).EQ.-1) ISID=5
12566             IDAU=N-1
12567             IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12568             K(ID,ISID)=K(ID,ISID)+IDAU
12569             K(IDAU,ISID)=MSTU(5)*ID
12570 C...Then redirect colour flow if mother octet.
12571           ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12572             IDAU=N-1
12573             IF(KCQ1(JT).EQ.0) IDAU=N
12574             K(ID,4)=K(ID,4)+IDAU
12575             K(ID,5)=K(ID,5)+IDAU
12576             K(IDAU,4)=MSTU(5)*ID
12577             K(IDAU,5)=MSTU(5)*ID
12578           ELSE
12579             ISID=4
12580             IF(KCQ1(JT).EQ.-1) ISID=5
12581             IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12582             K(ID,ISID)=K(ID,ISID)+(N-1)
12583             K(ID,9-ISID)=K(ID,9-ISID)+N
12584             K(N-1,ISID)=MSTU(5)*ID
12585             K(N,9-ISID)=MSTU(5)*ID
12586           ENDIF
12587         ENDIF
12588
12589 C...End loop over resonances for daughter flavour and mass selection.
12590         MSTU(10)=MSTU10
12591   240   IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12592      &  NINH=NINH+1
12593         IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12594      &  KFL1(JT).EQ.0) THEN
12595           WRITE(CODE,'(I9)') K(ID,2)
12596           WRITE(MASS,'(F9.3)') P(ID,5)
12597           CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12598      &    CODE//' with mass'//MASS)
12599           MINT(51)=1
12600           GOTO 630
12601         ENDIF
12602   250 CONTINUE
12603
12604 C...Check for allowed combinations. Skip if no decays.
12605       IF(JTMAX.EQ.1) THEN
12606         IF(KDCY(1).EQ.0) GOTO 620
12607       ELSEIF(JTMAX.EQ.2) THEN
12608         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
12609         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12610         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12611       ELSEIF(JTMAX.EQ.3) THEN
12612         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
12613         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12614         IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12615         IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12616         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12617         IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12618         IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12619       ENDIF
12620
12621 C...Special case: matrix element option for Z0 decay to quarks.
12622       IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12623      &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12624
12625 C...Check consistency of MSTJ options set.
12626         IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12627           CALL PYERRM(6,
12628      &    '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12629           MSTJ(110)=1
12630         ENDIF
12631         IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12632           CALL PYERRM(6,
12633      &    '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12634           MSTJ(111)=0
12635         ENDIF
12636
12637 C...Select alpha_strong behaviour.
12638         MST111=MSTU(111)
12639         PAR112=PARU(112)
12640         MSTU(111)=MSTJ(108)
12641         IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12642      &  MSTU(111)=1
12643         PARU(112)=PARJ(121)
12644         IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12645
12646 C...Find axial fraction in total cross section for scalar gluon model.
12647         PARJ(171)=0D0
12648         IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12649      &  (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12650           POLL=1D0-PARJ(131)*PARJ(132)
12651           SFF=1D0/(16D0*XW*XW1)
12652           SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12653      &    (PARJ(123)*PARJ(124))**2)
12654           SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12655           VE=4D0*XW-1D0
12656           HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
12657           HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
12658      &    (PARJ(132)-PARJ(131)))
12659           KFLC=IABS(KFL1(1))
12660           PMQ=PYMASS(KFLC)
12661           QF=KCHG(KFLC,1)/3D0
12662           VQ=1D0
12663           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
12664      &    1D0-(2D0*PMQ/P(ID,5))**2))
12665           VF=SIGN(1D0,QF)-4D0*QF*XW
12666           RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
12667      &    VF**2*HF1W)+VQ**3*HF1W
12668           IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
12669         ENDIF
12670
12671 C...Choice of jet configuration.
12672         CALL PYXJET(P(ID,5),NJET,CUT)
12673         KFLC=IABS(KFL1(1))
12674         KFLN=21
12675         IF(NJET.EQ.4) THEN
12676           CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
12677         ELSEIF(NJET.EQ.3) THEN
12678           CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
12679         ELSE
12680           MSTJ(120)=1
12681         ENDIF
12682
12683 C...Fill jet configuration; return if incorrect kinematics.
12684         NC=N-2
12685         IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
12686           CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
12687         ELSEIF(NJET.EQ.2) THEN
12688           CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
12689         ELSEIF(NJET.EQ.3) THEN
12690           CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
12691         ELSEIF(KFLN.EQ.21) THEN
12692           CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12693      &    X12,X14)
12694         ELSE
12695           CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12696      &    X12,X14)
12697         ENDIF
12698         IF(MSTU(24).NE.0) THEN
12699           MINT(51)=1
12700           MSTU(111)=MST111
12701           PARU(112)=PAR112
12702           GOTO 630
12703         ENDIF
12704
12705 C...Angular orientation according to matrix element.
12706         IF(MSTJ(106).EQ.1) THEN
12707           CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
12708           IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
12709           CTHE(1)=COS(THEZ)
12710           CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
12711           CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
12712         ENDIF
12713
12714 C...Boost partons to Z0 rest frame.
12715         CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
12716      &  P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12717
12718 C...Mark decayed resonance and add documentation lines,
12719         K(ID,1)=K(ID,1)+10
12720         IDOC=MINT(83)+MINT(4)
12721         DO 270 I=NC+1,N
12722           I1=MINT(83)+MINT(4)+1
12723           K(I,3)=I1
12724           IF(MSTP(128).GE.1) K(I,3)=ID
12725           IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
12726             MINT(4)=MINT(4)+1
12727             K(I1,1)=21
12728             K(I1,2)=K(I,2)
12729             K(I1,3)=IREF(IP,4)
12730             DO 260 J=1,5
12731               P(I1,J)=P(I,J)
12732   260       CONTINUE
12733           ENDIF
12734   270   CONTINUE
12735
12736 C...Generate parton shower.
12737         IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
12738
12739 C... End special case for Z0: skip ahead.
12740         MSTU(111)=MST111
12741         PARU(112)=PAR112
12742         GOTO 610
12743       ENDIF
12744
12745 C...Order incoming partons and outgoing resonances.
12746       IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
12747      &NINH.EQ.0) THEN
12748         ILIN(1)=MINT(84)+1
12749         IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
12750         IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
12751      &  ILIN(1)=2*MINT(84)+3-ILIN(1)
12752         ILIN(2)=2*MINT(84)+3-ILIN(1)
12753         IMIN=1
12754         IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12755      &  .EQ.36) IMIN=3
12756         IMAX=2
12757         IORD=1
12758         IF(K(IREF(IP,1),2).EQ.23) IORD=2
12759         IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
12760         IAKIPD=IABS(K(IREF(IP,IORD),2))
12761         IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
12762         IF(KDCY(IORD).EQ.0) IORD=3-IORD
12763
12764 C...Order decay products of resonances.
12765         DO 280 JT=IORD,3-IORD,3-2*IORD
12766           IF(KDCY(JT).EQ.0) THEN
12767             ILIN(IMAX+1)=NSD(JT)
12768             IMAX=IMAX+1
12769           ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
12770             ILIN(IMAX+1)=N+2*JT-1
12771             ILIN(IMAX+2)=N+2*JT
12772             IMAX=IMAX+2
12773             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12774             K(N+2*JT,2)=K(NSD(JT)+2,2)
12775           ELSE
12776             ILIN(IMAX+1)=N+2*JT
12777             ILIN(IMAX+2)=N+2*JT-1
12778             IMAX=IMAX+2
12779             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12780             K(N+2*JT,2)=K(NSD(JT)+2,2)
12781           ENDIF
12782   280   CONTINUE
12783
12784 C...Find charge, isospin, left- and righthanded couplings.
12785         DO 300 I=IMIN,IMAX
12786           DO 290 J=1,4
12787             COUP(I,J)=0D0
12788   290     CONTINUE
12789           KFA=IABS(K(ILIN(I),2))
12790           IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
12791           COUP(I,1)=KCHG(KFA,1)/3D0
12792           COUP(I,2)=(-1)**MOD(KFA,2)
12793           COUP(I,4)=-2D0*COUP(I,1)*XWV
12794           COUP(I,3)=COUP(I,2)+COUP(I,4)
12795   300   CONTINUE
12796
12797 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
12798         IF(ISUB.EQ.22) THEN
12799           DO 330 I=3,5,2
12800             I1=IORD
12801             IF(I.EQ.5) I1=3-IORD
12802             DO 320 J1=1,2
12803               DO 310 J2=1,2
12804                 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
12805      &          16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
12806      &          COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
12807      &          COUP(I,J2+2)**2
12808   310         CONTINUE
12809   320       CONTINUE
12810   330     CONTINUE
12811           COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
12812      &    (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
12813           COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
12814      &    (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
12815           IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
12816         ENDIF
12817       ENDIF
12818
12819 C...Select angular orientation type - Z'/W' only.
12820       MZPWP=0
12821       IF(ISUB.EQ.141) THEN
12822         IF(PYR(0).LT.PARU(130)) MZPWP=1
12823         IF(IP.EQ.2) THEN
12824           IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
12825           IAKIR=IABS(K(IREF(2,2),2))
12826           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12827           IF(IAKIR.LE.20) MZPWP=2
12828         ENDIF
12829         IF(IP.GE.3) MZPWP=2
12830       ELSEIF(ISUB.EQ.142) THEN
12831         IF(PYR(0).LT.PARU(136)) MZPWP=1
12832         IF(IP.EQ.2) THEN
12833           IAKIR=IABS(K(IREF(2,2),2))
12834           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12835           IF(IAKIR.LE.20) MZPWP=2
12836         ENDIF
12837         IF(IP.GE.3) MZPWP=2
12838       ENDIF
12839
12840 C...Select random angles (begin of weighting procedure).
12841   340 DO 350 JT=1,JTMAX
12842         IF(KDCY(JT).EQ.0) GOTO 350
12843         IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
12844           CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
12845           IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
12846           PHI(JT)=VINT(24)
12847         ELSE
12848           CTHE(JT)=2D0*PYR(0)-1D0
12849           PHI(JT)=PARU(2)*PYR(0)
12850         ENDIF
12851   350 CONTINUE
12852
12853       IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
12854 C...Construct massless four-vectors.
12855         DO 370 I=N+1,N+4
12856           K(I,1)=1
12857           DO 360 J=1,5
12858             P(I,J)=0D0
12859 C            V(I,J)=0D0
12860   360     CONTINUE
12861   370   CONTINUE
12862         DO 380 JT=1,JTMAX
12863           IF(KDCY(JT).EQ.0) GOTO 380
12864           ID=IREF(IP,JT)
12865           P(N+2*JT-1,3)=0.5D0*P(ID,5)
12866           P(N+2*JT-1,4)=0.5D0*P(ID,5)
12867           P(N+2*JT,3)=-0.5D0*P(ID,5)
12868           P(N+2*JT,4)=0.5D0*P(ID,5)
12869           CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
12870      &    P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12871   380   CONTINUE
12872
12873 C...Store incoming and outgoing momenta, with random rotation to
12874 C...avoid accidental zeroes in HA expressions.
12875         IF(ISUB.NE.0) THEN
12876           DO 400 I=1,IMAX
12877             K(N+4+I,1)=1
12878             P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
12879      &      P(ILIN(I),3)**2+P(ILIN(I),5)**2)
12880             P(N+4+I,5)=P(ILIN(I),5)
12881             DO 390 J=1,3
12882               P(N+4+I,J)=P(ILIN(I),J)
12883   390       CONTINUE
12884   400     CONTINUE
12885   410     THERR=ACOS(2D0*PYR(0)-1D0)
12886           PHIRR=PARU(2)*PYR(0)
12887           CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
12888           DO 430 I=1,IMAX
12889             IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
12890      &      GOTO 410
12891             DO 420 J=1,4
12892               PK(I,J)=P(N+4+I,J)
12893   420       CONTINUE
12894   430     CONTINUE
12895         ENDIF
12896
12897 C...Calculate internal products.
12898         IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
12899      &  ISUB.EQ.142) THEN
12900           DO 450 I1=IMIN,IMAX-1
12901             DO 440 I2=I1+1,IMAX
12902               HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
12903      &        PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
12904      &        CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
12905      &        SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
12906      &        (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
12907      &        CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
12908               HC(I1,I2)=CONJG(HA(I1,I2))
12909               IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
12910               IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
12911               HA(I2,I1)=-HA(I1,I2)
12912               HC(I2,I1)=-HC(I1,I2)
12913   440       CONTINUE
12914   450     CONTINUE
12915         ENDIF
12916
12917 C...Calculate four-products.
12918         IF(ISUB.NE.0) THEN
12919           DO 470 I=1,2
12920             DO 460 J=1,4
12921               PK(I,J)=-PK(I,J)
12922   460       CONTINUE
12923   470     CONTINUE
12924           DO 490 I1=IMIN,IMAX-1
12925             DO 480 I2=I1+1,IMAX
12926               PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
12927      &        PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
12928               PKK(I2,I1)=PKK(I1,I2)
12929   480       CONTINUE
12930   490     CONTINUE
12931         ENDIF
12932       ENDIF
12933
12934       KFAGM=IABS(IREF(IP,7))
12935       IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
12936 C...Isotropic decay selected by user.
12937         WT=1D0
12938         WTMAX=1D0
12939
12940       ELSEIF(JTMAX.EQ.3) THEN
12941 C...Isotropic decay when three mother particles.
12942         WT=1D0
12943         WTMAX=1D0
12944
12945       ELSEIF(IT4.GE.1) THEN
12946 C... Isotropic decay t -> b + W etc for 4th generation q and l.
12947         WT=1D0
12948         WTMAX=1D0
12949
12950       ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
12951      &  IREF(IP,7).EQ.36) THEN
12952 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
12953         IF(IP.EQ.1) WTMAX=SH**2
12954         IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
12955         KFA=IABS(K(IREF(IP,1),2))
12956         IF(KFA.EQ.23) THEN
12957           KFLF1A=IABS(KFL1(1))
12958           EF1=KCHG(KFLF1A,1)/3D0
12959           AF1=SIGN(1D0,EF1+0.1D0)
12960           VF1=AF1-4D0*EF1*XWV
12961           KFLF2A=IABS(KFL1(2))
12962           EF2=KCHG(KFLF2A,1)/3D0
12963           AF2=SIGN(1D0,EF2+0.1D0)
12964           VF2=AF2-4D0*EF2*XWV
12965           VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
12966           WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
12967      &    8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
12968         ELSEIF(KFA.EQ.24) THEN
12969           WT=16D0*PKK(3,5)*PKK(4,6)
12970         ELSE
12971           WT=WTMAX
12972         ENDIF
12973
12974       ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
12975      &  KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
12976      &  THEN
12977 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
12978         I1=IREF(IP,8)
12979         IF(MOD(KFAGM,2).EQ.0) THEN
12980           I2=N+1
12981           I3=N+2
12982         ELSE
12983           I2=N+2
12984           I3=N+1
12985         ENDIF
12986         I4=IREF(IP,2)
12987         WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
12988      &  P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
12989      &  P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
12990         WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
12991
12992       ELSEIF(ISUB.EQ.1) THEN
12993 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
12994         EI=KCHG(IABS(MINT(15)),1)/3D0
12995         AI=SIGN(1D0,EI+0.1D0)
12996         VI=AI-4D0*EI*XWV
12997         EF=KCHG(IABS(KFL1(1)),1)/3D0
12998         AF=SIGN(1D0,EF+0.1D0)
12999         VF=AF-4D0*EF*XWV
13000         RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13001         WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13002      &  (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13003         WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13004      &  (VI**2+AI**2)*VINT(114)*VF**2)
13005         WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13006      &  4D0*VI*AI*VINT(114)*VF*AF)
13007         WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13008      &  2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13009         WTMAX=2D0*(WT1+ABS(WT3))
13010
13011       ELSEIF(ISUB.EQ.2) THEN
13012 C...Angular weight for W+/- -> 2 quarks/leptons.
13013         RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13014         RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13015         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13016         WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13017         WTMAX=4D0
13018
13019       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13020 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13021 C...-> gluon/gamma + 2 quarks/leptons.
13022         CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13023      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13024      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13025         CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13026      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13027      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13028         CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13029      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13030      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13031         CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13032      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13033      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13034         WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13035      &  (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13036         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13037      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13038
13039       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13040 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13041 C...-> gluon/gamma + 2 quarks/leptons.
13042         WT=PKK(1,3)**2+PKK(2,4)**2
13043         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13044
13045       ELSEIF(ISUB.EQ.22) THEN
13046 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13047         S34=P(IREF(IP,IORD),5)**2
13048         S56=P(IREF(IP,3-IORD),5)**2
13049         TI=PKK(1,3)+PKK(1,4)+S34
13050         UI=PKK(1,5)+PKK(1,6)+S56
13051         TIR=REAL(TI)
13052         UIR=REAL(UI)
13053         FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13054         FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13055         FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13056         FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13057         FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13058         FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13059         FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13060         FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13061         WT=
13062      &  CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13063      &  CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13064      &  CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13065      &  CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13066         WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13067      &  (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13068      &  ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13069      &  1D0/UI**2))
13070
13071       ELSEIF(ISUB.EQ.23) THEN
13072 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13073         D34=P(IREF(IP,IORD),5)**2
13074         D56=P(IREF(IP,3-IORD),5)**2
13075         DT=PKK(1,3)+PKK(1,4)+D34
13076         DU=PKK(1,5)+PKK(1,6)+D56
13077         FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13078         CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13079         CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13080         FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13081      &  REAL(CBWZ)*FGK(1,2,5,6,3,4))
13082         FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13083      &  REAL(CBWZ)*FGK(1,2,6,5,3,4))
13084         WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13085         WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13086      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13087
13088       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13089 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13090 C...(or H0, or A0).
13091         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13092      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13093      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13094         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13095      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13096
13097       ELSEIF(ISUB.EQ.25) THEN
13098 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13099         POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13100         POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13101         D34=P(IREF(IP,IORD),5)**2
13102         D56=P(IREF(IP,3-IORD),5)**2
13103         DT=PKK(1,3)+PKK(1,4)+D34
13104         DU=PKK(1,5)+PKK(1,6)+D56
13105         FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13106         CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13107         CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13108         CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13109         CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13110         FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13111      &  REAL(CBWW)*FGK(1,2,5,6,3,4))
13112         FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13113         IF(MSTP(50).LE.0) THEN
13114           WT=FGK135**2+(CCWW*FGK253)**2
13115           WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13116      &    CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13117      &    DJGK(DT,DU)))
13118         ELSE
13119           WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13120           WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13121      &    CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13122      &    POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13123         ENDIF
13124
13125       ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13126 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13127 C...(or H0, or A0).
13128         WT=PKK(1,3)*PKK(2,4)
13129         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13130
13131       ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13132 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13133 C...-> f + 2 quarks/leptons.
13134         CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13135      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13136      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13137         CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13138      &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13139      &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13140         CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13141      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13142      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13143         CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13144      &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13145      &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13146         IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13147      &  PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13148         IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13149      &  PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13150         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13151      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13152
13153       ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13154 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13155         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13156         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13157         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13158
13159       ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13160      &  ISUB.EQ.77) THEN
13161 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13162         WT=16D0*PKK(3,5)*PKK(4,6)
13163         WTMAX=SH**2
13164
13165       ELSEIF(ISUB.EQ.110) THEN
13166 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13167         WT=1D0
13168         WTMAX=1D0
13169
13170       ELSEIF(ISUB.EQ.141) THEN
13171         IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13172 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13173 C...Couplings of incoming flavour.
13174           KFAI=IABS(MINT(15))
13175           EI=KCHG(KFAI,1)/3D0
13176           AI=SIGN(1D0,EI+0.1D0)
13177           VI=AI-4D0*EI*XWV
13178           KFAIC=1
13179           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13180           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13181           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13182           IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13183             VPI=PARU(119+2*KFAIC)
13184             API=PARU(120+2*KFAIC)
13185           ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13186             VPI=PARJ(178+2*KFAIC)
13187             API=PARJ(179+2*KFAIC)
13188           ELSE
13189             VPI=PARJ(186+2*KFAIC)
13190             API=PARJ(187+2*KFAIC)
13191           ENDIF
13192 C...Couplings of final flavour.
13193           KFAF=IABS(KFL1(1))
13194           EF=KCHG(KFAF,1)/3D0
13195           AF=SIGN(1D0,EF+0.1D0)
13196           VF=AF-4D0*EF*XWV
13197           KFAFC=1
13198           IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13199           IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13200           IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13201           IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13202             VPF=PARU(119+2*KFAFC)
13203             APF=PARU(120+2*KFAFC)
13204           ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13205             VPF=PARJ(178+2*KFAFC)
13206             APF=PARJ(179+2*KFAFC)
13207           ELSE
13208             VPF=PARJ(186+2*KFAFC)
13209             APF=PARJ(187+2*KFAFC)
13210           ENDIF
13211 C...Asymmetry and weight.
13212           ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13213      &    4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13214      &    (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13215      &    (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13216      &    EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13217      &    (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13218      &    (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13219           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13220           WTMAX=2D0+ABS(ASYM)
13221         ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13222 C...Angular weight for f + fbar -> Z' -> W+ + W-.
13223           RM1=P(NSD(1)+1,5)**2/SH
13224           RM2=P(NSD(1)+2,5)**2/SH
13225           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13226      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13227           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13228      &    (RM2-RM1)**2)
13229           WT=CFLAT+CCOS2*CTHE(1)**2
13230           WTMAX=CFLAT+MAX(0D0,CCOS2)
13231         ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13232      &    IABS(KFL1(1)).EQ.37)) THEN
13233 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13234           WT=1D0-CTHE(1)**2
13235           WTMAX=1D0
13236         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13237 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13238           RM1=P(NSD(1)+1,5)**2/SH
13239           RM2=P(NSD(1)+2,5)**2/SH
13240           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13241           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13242           WTMAX=1D0+FLAM2/(8D0*RM1)
13243         ELSEIF(MZPWP.EQ.0) THEN
13244 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13245 C...(W:s like if intermediate Z).
13246           D34=P(IREF(IP,IORD),5)**2
13247           D56=P(IREF(IP,3-IORD),5)**2
13248           DT=PKK(1,3)+PKK(1,4)+D34
13249           DU=PKK(1,5)+PKK(1,6)+D56
13250           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13251           FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13252           WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13253           WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13254      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13255         ELSEIF(MZPWP.EQ.1) THEN
13256 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13257 C...(W:s approximately longitudinal, like if intermediate H).
13258           WT=16D0*PKK(3,5)*PKK(4,6)
13259           WTMAX=SH**2
13260         ELSE
13261 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13262 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13263           WT=1D0
13264           WTMAX=1D0
13265         ENDIF
13266
13267       ELSEIF(ISUB.EQ.142) THEN
13268         IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13269 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13270           KFAI=IABS(MINT(15))
13271           KFAIC=1
13272           IF(KFAI.GT.10) KFAIC=2
13273           VI=PARU(129+2*KFAIC)
13274           AI=PARU(130+2*KFAIC)
13275           KFAF=IABS(KFL1(1))
13276           KFAFC=1
13277           IF(KFAF.GT.10) KFAFC=2
13278           VF=PARU(129+2*KFAFC)
13279           AF=PARU(130+2*KFAFC)
13280           ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13281           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13282           WTMAX=2D0+ABS(ASYM)
13283         ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13284 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13285           RM1=P(NSD(1)+1,5)**2/SH
13286           RM2=P(NSD(1)+2,5)**2/SH
13287           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13288      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13289           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13290      &    (RM2-RM1)**2)
13291           WT=CFLAT+CCOS2*CTHE(1)**2
13292           WTMAX=CFLAT+MAX(0D0,CCOS2)
13293         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13294 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13295           RM1=P(NSD(1)+1,5)**2/SH
13296           RM2=P(NSD(1)+2,5)**2/SH
13297           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13298           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13299           WTMAX=1D0+FLAM2/(8D0*RM1)
13300         ELSEIF(MZPWP.EQ.0) THEN
13301 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13302 C...(W/Z like if intermediate W).
13303           D34=P(IREF(IP,IORD),5)**2
13304           D56=P(IREF(IP,3-IORD),5)**2
13305           DT=PKK(1,3)+PKK(1,4)+D34
13306           DU=PKK(1,5)+PKK(1,6)+D56
13307           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13308           FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13309           WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13310           WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13311      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13312         ELSEIF(MZPWP.EQ.1) THEN
13313 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13314 C...(W/Z approximately longitudinal, like if intermediate H).
13315           WT=16D0*PKK(3,5)*PKK(4,6)
13316           WTMAX=SH**2
13317         ELSE
13318 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13319 C...t + bbar -> t + W + bbar.
13320           WT=1D0
13321           WTMAX=1D0
13322         ENDIF
13323
13324       ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13325      &  THEN
13326 C...Isotropic decay of leptoquarks (assumed spin 0).
13327         WT=1D0
13328         WTMAX=1D0
13329
13330       ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13331 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13332         SIDE=1D0
13333         IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13334         IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13335           WT=1D0+SIDE*CTHE(1)
13336           WTMAX=2D0
13337         ELSEIF(IP.EQ.1) THEN
13338           RM1=P(NSD(1)+1,5)**2/SH
13339           WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13340           WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13341         ELSE
13342 C...W/Z decay assumed isotropic, since not known.
13343           WT=1D0
13344           WTMAX=1D0
13345         ENDIF
13346
13347       ELSEIF(ISUB.EQ.149) THEN
13348 C...Isotropic decay of techni-eta.
13349         WT=1D0
13350         WTMAX=1D0
13351
13352       ELSEIF(ISUB.EQ.191) THEN
13353         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13354 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13355 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13356           WT=1D0-CTHE(1)**2
13357           WTMAX=1D0
13358         ELSEIF(IP.EQ.1) THEN
13359 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13360           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13361           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13362           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13363           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13364           KFAI=IABS(MINT(15))
13365           EI=KCHG(KFAI,1)/3D0
13366           AI=SIGN(1D0,EI+0.1D0)
13367           VI=AI-4D0*EI*XWV
13368           VALI=0.5D0*(VI+AI)
13369           VARI=0.5D0*(VI-AI)
13370           ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13371           ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13372           KFAF=IABS(KFL1(1))
13373           EF=KCHG(KFAF,1)/3D0
13374           AF=SIGN(1D0,EF+0.1D0)
13375           VF=AF-4D0*EF*XWV
13376           VALF=0.5D0*(VF+AF)
13377           VARF=0.5D0*(VF-AF)
13378           ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13379           ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13380           ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13381           AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13382           WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13383           WTMAX=4D0*MAX(ASAME,AFLIP)
13384         ELSE
13385 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13386           WT=1D0
13387           WTMAX=1D0
13388         ENDIF
13389
13390       ELSEIF(ISUB.EQ.192) THEN
13391         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13392 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13393 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13394           WT=1D0-CTHE(1)**2
13395           WTMAX=1D0
13396         ELSEIF(IP.EQ.1) THEN
13397 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13398           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13399           WT=(1D0+CTHESG)**2
13400           WTMAX=4D0
13401         ELSE
13402 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13403           WT=1D0
13404           WTMAX=1D0
13405         ENDIF
13406
13407       ELSEIF(ISUB.EQ.193) THEN
13408         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13409 C...Angular weight for f + fbar -> omega_tc0 ->
13410 C...gamma pi_tc0 or Z0 pi_tc0.
13411           WT=1D0+CTHE(1)**2
13412           WTMAX=2D0
13413         ELSEIF(IP.EQ.1) THEN
13414 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13415           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13416           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13417           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13418           KFAI=IABS(MINT(15))
13419           EI=KCHG(KFAI,1)/3D0
13420           AI=SIGN(1D0,EI+0.1D0)
13421           VI=AI-4D0*EI*XWV
13422           VALI=0.5D0*(VI+AI)
13423           VARI=0.5D0*(VI-AI)
13424           BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13425           BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13426           KFAF=IABS(KFL1(1))
13427           EF=KCHG(KFAF,1)/3D0
13428           AF=SIGN(1D0,EF+0.1D0)
13429           VF=AF-4D0*EF*XWV
13430           VALF=0.5D0*(VF+AF)
13431           VARF=0.5D0*(VF-AF)
13432           BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13433           BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13434           BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13435           BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13436           WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13437           WTMAX=4D0*MAX(BSAME,BFLIP)
13438         ELSE
13439 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13440           WT=1D0
13441           WTMAX=1D0
13442         ENDIF
13443
13444       ELSEIF(ISUB.EQ.353) THEN
13445 C...Angular weight for Z_R0 -> 2 quarks/leptons.
13446         EI=KCHG(IABS(MINT(15)),1)/3D0
13447         AI=SIGN(1D0,EI+0.1D0)
13448         VI=AI-4D0*EI*XWV
13449         EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13450         AF=SIGN(1D0,EF+0.1D0)
13451         VF=AF-4D0*EF*XWV
13452         RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13453         WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13454         WT2=RMF*(VI**2+AI**2)*VF**2
13455         WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13456         WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13457      &  2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13458         WTMAX=2D0*(WT1+ABS(WT3))
13459
13460       ELSEIF(ISUB.EQ.354) THEN
13461 C...Angular weight for W_R+/- -> 2 quarks/leptons.
13462         RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13463         RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13464         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13465         WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13466         WTMAX=4D0
13467
13468       ELSEIF(ISUB.EQ.391) THEN
13469 C...Angular weight for f + fbar -> G* -> f + fbar
13470         IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13471           WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13472           WTMAX=2D0
13473 C...Other G* decays not yet implemented angular distributions.
13474         ELSE
13475           WT=1D0
13476           WTMAX=1D0
13477         ENDIF
13478
13479       ELSEIF(ISUB.EQ.392) THEN
13480 C...Angular weight for g + g -> G* -> f + fbar
13481         IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13482           WT=1D0-CTHE(1)**4
13483           WTMAX=1D0
13484 C...Other G* decays not yet implemented angular distributions.
13485         ELSE
13486           WT=1D0
13487           WTMAX=1D0
13488         ENDIF
13489
13490 C...Obtain correct angular distribution by rejection techniques.
13491       ELSE
13492         WT=1D0
13493         WTMAX=1D0
13494       ENDIF
13495       IF(WT.LT.PYR(0)*WTMAX) GOTO 340
13496
13497 C...Construct massive four-vectors using angles chosen.
13498   500 DO 600 JT=1,JTMAX
13499         IF(KDCY(JT).EQ.0) GOTO 600
13500         ID=IREF(IP,JT)
13501         DO 510 J=1,5
13502           DPMO(J)=P(ID,J)
13503   510   CONTINUE
13504         DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13505 CMRENNA++
13506         IF(KFL3(JT).EQ.0) THEN
13507           CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13508      &    DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13509           N0=NSD(JT)+2
13510         ELSE
13511           CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13512      &    DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13513           N0=NSD(JT)+3
13514         ENDIF
13515
13516         DO 520 J=1,4
13517           VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13518   520   CONTINUE
13519 C...Fill in position of decay vertex.
13520         DO 540 I=NSD(JT)+1,N0
13521           DO 530 J=1,4
13522             V(I,J)=VDCY(J)
13523   530     CONTINUE
13524           V(I,5)=0D0
13525   540   CONTINUE
13526 CMRENNA--
13527
13528 C...Mark decayed resonances; trace history.
13529         K(ID,1)=K(ID,1)+10
13530         KFA=IABS(K(ID,2))
13531         KCA=PYCOMP(KFA)
13532         IF(KCQM(JT).NE.0) THEN
13533 C...Do not kill colour flow through coloured resonance!
13534         ELSE
13535           K(ID,4)=NSD(JT)+1
13536           K(ID,5)=NSD(JT)+2
13537           IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
13538         ENDIF
13539
13540 C...Add documentation lines.
13541         IF(IRES.EQ.0) THEN
13542           IDOC=MINT(83)+MINT(4)
13543 CMRENNA+++
13544           IHI=NSD(JT)+2
13545           IF(KFL3(JT).NE.0) IHI=IHI+1
13546           DO 560 I=NSD(JT)+1,IHI
13547 CMRENNA---
13548             I1=MINT(83)+MINT(4)+1
13549             K(I,3)=I1
13550             IF(MSTP(128).GE.1) K(I,3)=ID
13551             IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13552               MINT(4)=MINT(4)+1
13553               K(I1,1)=21
13554               K(I1,2)=K(I,2)
13555               K(I1,3)=IREF(IP,JT+3)
13556               DO 550 J=1,5
13557                 P(I1,J)=P(I,J)
13558   550         CONTINUE
13559             ENDIF
13560   560     CONTINUE
13561         ELSE
13562           K(NSD(JT)+1,3)=ID
13563           K(NSD(JT)+2,3)=ID
13564           IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
13565         ENDIF
13566
13567 C...Do showering of two or three objects.
13568         NSHBEF=N
13569         IF(MSTP(71).GE.1) THEN
13570           IF(KFL3(JT).EQ.0) THEN
13571             CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13572           ELSE
13573             CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13574           ENDIF
13575         ENDIF
13576         NSHAFT=N
13577         IF(JT.EQ.1) NAFT1=N
13578
13579 C...Check if decay products moved by shower.
13580         NSD1=NSD(JT)+1
13581         NSD2=NSD(JT)+2
13582         NSD3=NSD(JT)+3
13583         IF(NSHAFT.GT.NSHBEF) THEN
13584           IF(K(NSD1,1).GT.10) THEN
13585             DO 570 I=NSHBEF+1,NSHAFT
13586               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13587   570       CONTINUE
13588           ENDIF
13589           IF(K(NSD2,1).GT.10) THEN
13590             DO 580 I=NSHBEF+1,NSHAFT
13591               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13592      &        I.NE.NSD1) NSD2=I
13593   580       CONTINUE
13594           ENDIF
13595           IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13596             DO 590 I=NSHBEF+1,NSHAFT
13597               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13598      &        I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13599   590       CONTINUE
13600           ENDIF
13601         ENDIF
13602
13603 C...Store decay products for further treatment.
13604         NP=NP+1
13605         IREF(NP,1)=NSD1
13606         IREF(NP,2)=NSD2
13607         IREF(NP,3)=0
13608         IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13609         IREF(NP,4)=IDOC+1
13610         IREF(NP,5)=IDOC+2
13611         IREF(NP,6)=0
13612         IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13613         IREF(NP,7)=K(IREF(IP,JT),2)
13614         IREF(NP,8)=IREF(IP,JT)
13615   600 CONTINUE
13616
13617 C...Fill information for 2 -> 1 -> 2.
13618   610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
13619         MINT(7)=MINT(83)+6+2*ISET(ISUB)
13620         MINT(8)=MINT(83)+7+2*ISET(ISUB)
13621         MINT(25)=KFL1(1)
13622         MINT(26)=KFL2(1)
13623         VINT(23)=CTHE(1)
13624         RM3=P(N-1,5)**2/SH
13625         RM4=P(N,5)**2/SH
13626         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13627         VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
13628         VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
13629         VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
13630         VINT(47)=SQRT(VINT(48))
13631       ENDIF
13632
13633 C...Possibility of colour rearrangement in W+W- events.
13634       IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
13635         IAKF1=IABS(KFL1(1))
13636         IAKF2=IABS(KFL1(2))
13637         IAKF3=IABS(KFL2(1))
13638         IAKF4=IABS(KFL2(2))
13639         IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
13640      &  MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
13641      &  PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
13642       ENDIF
13643
13644 C...Loop back if needed.
13645   620 IF(IP.LT.NP) GOTO 150
13646
13647 C...Boost back to standard frame.
13648   630 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
13649      &BEZIN)
13650
13651       RETURN
13652       END
13653
13654 C*********************************************************************
13655
13656 C...PYMULT
13657 C...Initializes treatment of multiple interactions, selects kinematics
13658 C...of hardest interaction if low-pT physics included in run, and
13659 C...generates all non-hardest interactions.
13660
13661       SUBROUTINE PYMULT(MMUL)
13662
13663 C...Double precision and integer declarations.
13664       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13665       IMPLICIT INTEGER(I-N)
13666       INTEGER PYK,PYCHGE,PYCOMP
13667 C...Commonblocks.
13668       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13669       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13670       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13671       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13672       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13673       COMMON/PYINT1/MINT(400),VINT(400)
13674       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13675       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13676       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
13677       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
13678       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13679      &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
13680 C...Local arrays and saved variables.
13681       DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
13682       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
13683
13684 C...Initialization of multiple interaction treatment.
13685       IF(MMUL.EQ.1) THEN
13686         IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
13687         ISUB=96
13688         MINT(1)=96
13689         VINT(63)=0D0
13690         VINT(64)=0D0
13691         VINT(143)=1D0
13692         VINT(144)=1D0
13693
13694 C...Loop over phase space points: xT2 choice in 20 bins.
13695   100   SIGSUM=0D0
13696         DO 120 IXT2=1,20
13697           NMUL(IXT2)=MSTP(83)
13698           SIGM(IXT2)=0D0
13699           DO 110 ITRY=1,MSTP(83)
13700             RSCA=0.05D0*((21-IXT2)-PYR(0))
13701             XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
13702             XT2=MAX(0.01D0*VINT(149),XT2)
13703             VINT(25)=XT2
13704
13705 C...Choose tau and y*. Calculate cos(theta-hat).
13706             IF(PYR(0).LE.COEF(ISUB,1)) THEN
13707               TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13708               TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13709             ELSE
13710               TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13711             ENDIF
13712             VINT(21)=TAU
13713             CALL PYKLIM(2)
13714             RYST=PYR(0)
13715             MYST=1
13716             IF(RYST.GT.COEF(ISUB,8)) MYST=2
13717             IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13718             CALL PYKMAP(2,MYST,PYR(0))
13719             VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13720
13721 C...Calculate differential cross-section.
13722             VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
13723             CALL PYSIGH(NCHN,SIGS)
13724             SIGM(IXT2)=SIGM(IXT2)+SIGS
13725   110     CONTINUE
13726           SIGSUM=SIGSUM+SIGM(IXT2)
13727   120   CONTINUE
13728         SIGSUM=SIGSUM/(20D0*MSTP(83))
13729
13730 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13731         IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
13732           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
13733      &    PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
13734           PARP(82)=0.9D0*PARP(82)
13735           VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
13736      &    VINT(2)
13737           GOTO 100
13738         ENDIF
13739         IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
13740      &  PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
13741
13742 C...Start iteration to find k factor.
13743         YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
13744         SO=0.5D0
13745         XI=0D0
13746         YI=0D0
13747         XF=0D0
13748         YF=0D0
13749         XK=0.5D0
13750         IIT=0
13751   130   IF(IIT.EQ.0) THEN
13752           XK=2D0*XK
13753         ELSEIF(IIT.EQ.1) THEN
13754           XK=0.5D0*XK
13755         ELSE
13756           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
13757         ENDIF
13758
13759 C...Evaluate overlap integrals.
13760         IF(MSTP(82).EQ.2) THEN
13761           SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
13762           SOP=SP/PARU(1)
13763         ELSE
13764           IF(MSTP(82).EQ.3) DELTAB=0.02D0
13765           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
13766           SP=0D0
13767           SOP=0D0
13768           B=-0.5D0*DELTAB
13769   140     B=B+DELTAB
13770           IF(MSTP(82).EQ.3) THEN
13771             OV=EXP(-B**2)/PARU(2)
13772           ELSE
13773             CQ2=PARP(84)**2
13774             OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
13775      &      2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
13776      &      EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
13777      &      PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
13778           ENDIF
13779           PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
13780           SP=SP+PARU(2)*B*DELTAB*PACC
13781           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
13782           IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
13783         ENDIF
13784         YK=PARU(1)*XK*SO/SP
13785
13786 C...Continue iteration until convergence.
13787         IF(YK.LT.YKE) THEN
13788           XI=XK
13789           YI=YK
13790           IF(IIT.EQ.1) IIT=2
13791         ELSE
13792           XF=XK
13793           YF=YK
13794           IF(IIT.EQ.0) IIT=1
13795         ENDIF
13796         IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
13797
13798 C...Store some results for subsequent use.
13799         VINT(145)=SIGSUM
13800         VINT(146)=SOP/SO
13801         VINT(147)=SOP/SP
13802
13803 C...Initialize iteration in xT2 for hardest interaction.
13804       ELSEIF(MMUL.EQ.2) THEN
13805         IF(MSTP(82).LE.0) THEN
13806         ELSEIF(MSTP(82).EQ.1) THEN
13807           XT2=1D0
13808           SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13809           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13810      &    VINT(317)/(VINT(318)*VINT(320))
13811           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13812         ELSEIF(MSTP(82).EQ.2) THEN
13813           XT2=1D0
13814           XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
13815      &    VINT(149)*(1D0+VINT(149))
13816         ELSE
13817           XC2=4D0*CKIN(3)**2/VINT(2)
13818           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
13819         ENDIF
13820
13821       ELSEIF(MMUL.EQ.3) THEN
13822 C...Low-pT or multiple interactions (first semihard interaction):
13823 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13824 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13825         ISUB=MINT(1)
13826         IF(MSTP(82).LE.0) THEN
13827           XT2=0D0
13828         ELSEIF(MSTP(82).EQ.1) THEN
13829           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
13830         ELSEIF(MSTP(82).EQ.2) THEN
13831           IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
13832      &    VINT(149)))).GT.PYR(0)) XT2=1D0
13833           IF(XT2.GE.1D0) THEN
13834             XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
13835      &      PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
13836      &      VINT(149)
13837           ELSE
13838             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
13839      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
13840      &      VINT(149)
13841           ENDIF
13842           XT2=MAX(0.01D0*VINT(149),XT2)
13843         ELSE
13844           XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
13845      &    PYR(0)*(1D0-XC2))-VINT(149)
13846           XT2=MAX(0.01D0*VINT(149),XT2)
13847         ENDIF
13848         VINT(25)=XT2
13849
13850 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13851         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
13852           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
13853           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
13854           ISUB=95
13855           MINT(1)=ISUB
13856           VINT(21)=0.01D0*VINT(149)
13857           VINT(22)=0D0
13858           VINT(23)=0D0
13859           VINT(25)=0.01D0*VINT(149)
13860
13861         ELSE
13862 C...Multiple interactions (first semihard interaction).
13863 C...Choose tau and y*. Calculate cos(theta-hat).
13864           IF(PYR(0).LE.COEF(ISUB,1)) THEN
13865             TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13866             TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13867           ELSE
13868             TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13869           ENDIF
13870           VINT(21)=TAU
13871           CALL PYKLIM(2)
13872           RYST=PYR(0)
13873           MYST=1
13874           IF(RYST.GT.COEF(ISUB,8)) MYST=2
13875           IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13876           CALL PYKMAP(2,MYST,PYR(0))
13877           VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13878         ENDIF
13879         VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
13880
13881 C...Store results of cross-section calculation.
13882       ELSEIF(MMUL.EQ.4) THEN
13883         ISUB=MINT(1)
13884         XTS=VINT(25)
13885         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
13886         IF(ISET(ISUB).EQ.2)
13887      &  XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13888         IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
13889         RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
13890      &  (XTS+VINT(149))))
13891         IRBIN=INT(1D0+20D0*RBIN)
13892         IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
13893           NMUL(IRBIN)=NMUL(IRBIN)+1
13894           SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
13895         ENDIF
13896
13897 C...Choose impact parameter.
13898       ELSEIF(MMUL.EQ.5) THEN
13899         ISUB=MINT(1)
13900   150   IF(MSTP(82).EQ.3) THEN
13901           VINT(148)=PYR(0)/(PARU(2)*VINT(147))
13902         ELSE
13903           RTYPE=PYR(0)
13904           CQ2=PARP(84)**2
13905           IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
13906             B2=-LOG(PYR(0))
13907           ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
13908             B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
13909           ELSE
13910             B2=-CQ2*LOG(PYR(0))
13911           ENDIF
13912           VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
13913      &    (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
13914      &    PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
13915         ENDIF
13916
13917 C...Multiple interactions (variable impact parameter) : reject with
13918 C...probability exp(-overlap*cross-section above pT/normalization).
13919         RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
13920         SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
13921         DO 160 IBIN=IRBIN+1,20
13922           RNCOR=RNCOR+NMUL(IBIN)
13923           SIGCOR=SIGCOR+SIGM(IBIN)
13924   160   CONTINUE
13925         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
13926         IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
13927         VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
13928      &  SIGABV/MAX(1D-10,SIGT(0,0,5))))
13929         IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
13930      &  ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
13931      &  .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
13932           IF(VINT(150).LT.PYR(0)) GOTO 150
13933           VINT(150)=1D0
13934         ENDIF
13935
13936 C...Generate additional multiple semihard interactions.
13937       ELSEIF(MMUL.EQ.6) THEN
13938         ISUBSV=MINT(1)
13939         DO 170 J=11,80
13940           VINTSV(J)=VINT(J)
13941   170   CONTINUE
13942         ISUB=96
13943         MINT(1)=96
13944         VINT(151)=0D0
13945         VINT(152)=0D0
13946
13947 C...Reconstruct strings in hard scattering.
13948         NMAX=MINT(84)+4
13949         IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
13950         IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
13951         NSTR=0
13952         DO 190 I=MINT(84)+1,NMAX
13953           KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
13954           IF(KCS.EQ.0) GOTO 190
13955           DO 180 J=1,4
13956             IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
13957             IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
13958             IF(J.LE.2) THEN
13959               IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
13960             ELSE
13961               IST=MOD(K(I,J+1),MSTU(5))
13962             ENDIF
13963             IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
13964             IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
13965             NSTR=NSTR+1
13966             IF(J.EQ.1.OR.J.EQ.4) THEN
13967               KSTR(NSTR,1)=I
13968               KSTR(NSTR,2)=IST
13969             ELSE
13970               KSTR(NSTR,1)=IST
13971               KSTR(NSTR,2)=I
13972             ENDIF
13973   180     CONTINUE
13974   190   CONTINUE
13975
13976 C...Set up starting values for iteration in xT2.
13977         IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
13978      &  ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
13979      &  ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
13980      &  ISUBSV.NE.96)) THEN
13981           XT2=(1D0-VINT(141))*(1D0-VINT(142))
13982         ELSE
13983           XT2=VINT(25)
13984           IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
13985           IF(ISET(ISUBSV).EQ.2)
13986      &    XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13987           IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
13988         ENDIF
13989         IF(MSTP(82).LE.1) THEN
13990           SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13991           IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13992      &    VINT(317)/(VINT(318)*VINT(320))
13993           XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13994         ELSE
13995           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
13996      &    MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
13997         ENDIF
13998         VINT(63)=0D0
13999         VINT(64)=0D0
14000         VINT(143)=1D0-VINT(141)
14001         VINT(144)=1D0-VINT(142)
14002
14003 C...Iterate downwards in xT2.
14004   200   IF(MSTP(82).LE.1) THEN
14005           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14006           IF(XT2.LT.VINT(149)) GOTO 250
14007         ELSE
14008           IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14009           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14010      &    LOG(PYR(0)))-VINT(149)
14011           IF(XT2.LE.0D0) GOTO 250
14012           XT2=MAX(0.01D0*VINT(149),XT2)
14013         ENDIF
14014         VINT(25)=XT2
14015
14016 C...Choose tau and y*. Calculate cos(theta-hat).
14017         IF(PYR(0).LE.COEF(ISUB,1)) THEN
14018           TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14019           TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14020         ELSE
14021           TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14022         ENDIF
14023         VINT(21)=TAU
14024         CALL PYKLIM(2)
14025         RYST=PYR(0)
14026         MYST=1
14027         IF(RYST.GT.COEF(ISUB,8)) MYST=2
14028         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14029         CALL PYKMAP(2,MYST,PYR(0))
14030         VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14031
14032 C...Check that x not used up. Accept or reject kinematical variables.
14033         X1M=SQRT(TAU)*EXP(VINT(22))
14034         X2M=SQRT(TAU)*EXP(-VINT(22))
14035         IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14036         VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14037         CALL PYSIGH(NCHN,SIGS)
14038         IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14039         IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14040
14041 C...Reset K, P and V vectors. Select some variables.
14042         DO 220 I=N+1,N+2
14043           DO 210 J=1,5
14044             K(I,J)=0
14045             P(I,J)=0D0
14046             V(I,J)=0D0
14047   210     CONTINUE
14048   220   CONTINUE
14049         RFLAV=PYR(0)
14050         PT=0.5D0*VINT(1)*SQRT(XT2)
14051         PHI=PARU(2)*PYR(0)
14052         CTH=VINT(23)
14053
14054 C...Add first parton to event record.
14055         K(N+1,1)=3
14056         K(N+1,2)=21
14057         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14058      &  1+INT((2D0+PARJ(2))*PYR(0))
14059         P(N+1,1)=PT*COS(PHI)
14060         P(N+1,2)=PT*SIN(PHI)
14061         P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14062         P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14063         P(N+1,5)=0D0
14064
14065 C...Add second parton to event record.
14066         K(N+2,1)=3
14067         K(N+2,2)=21
14068         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14069         P(N+2,1)=-P(N+1,1)
14070         P(N+2,2)=-P(N+1,2)
14071         P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14072         P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14073         P(N+2,5)=0D0
14074
14075         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14076 C....Choose relevant string pieces to place gluons on.
14077           DO 240 I=N+1,N+2
14078             DMIN=1D8
14079             DO 230 ISTR=1,NSTR
14080               I1=KSTR(ISTR,1)
14081               I2=KSTR(ISTR,2)
14082               DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14083      &        P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14084      &        P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14085      &        P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14086               IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14087                 DMIN=DIST
14088                 IST1=I1
14089                 IST2=I2
14090                 ISTM=ISTR
14091               ENDIF
14092   230       CONTINUE
14093
14094 C....Colour flow adjustments, new string pieces.
14095             IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14096      &      MOD(K(IST1,4),MSTU(5))
14097             IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14098      &      MSTU(5)*(K(IST1,5)/MSTU(5))+I
14099             K(I,5)=MSTU(5)*IST1
14100             K(I,4)=MSTU(5)*IST2
14101             IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14102      &      MOD(K(IST2,5),MSTU(5))
14103             IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14104      &      MSTU(5)*(K(IST2,4)/MSTU(5))+I
14105             KSTR(ISTM,2)=I
14106             KSTR(NSTR+1,1)=I
14107             KSTR(NSTR+1,2)=IST2
14108             NSTR=NSTR+1
14109   240     CONTINUE
14110
14111 C...String drawing and colour flow for gluon loop.
14112         ELSEIF(K(N+1,2).EQ.21) THEN
14113           K(N+1,4)=MSTU(5)*(N+2)
14114           K(N+1,5)=MSTU(5)*(N+2)
14115           K(N+2,4)=MSTU(5)*(N+1)
14116           K(N+2,5)=MSTU(5)*(N+1)
14117           KSTR(NSTR+1,1)=N+1
14118           KSTR(NSTR+1,2)=N+2
14119           KSTR(NSTR+2,1)=N+2
14120           KSTR(NSTR+2,2)=N+1
14121           NSTR=NSTR+2
14122
14123 C...String drawing and colour flow for qqbar pair.
14124         ELSE
14125           K(N+1,4)=MSTU(5)*(N+2)
14126           K(N+2,5)=MSTU(5)*(N+1)
14127           KSTR(NSTR+1,1)=N+1
14128           KSTR(NSTR+1,2)=N+2
14129           NSTR=NSTR+1
14130         ENDIF
14131
14132 C...Update remaining energy; iterate.
14133         N=N+2
14134         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14135           CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14136           IF(MSTU(21).GE.1) RETURN
14137         ENDIF
14138         MINT(31)=MINT(31)+1
14139         VINT(151)=VINT(151)+VINT(41)
14140         VINT(152)=VINT(152)+VINT(42)
14141         VINT(143)=VINT(143)-VINT(41)
14142         VINT(144)=VINT(144)-VINT(42)
14143         IF(MINT(31).LT.240) GOTO 200
14144   250   CONTINUE
14145         MINT(1)=ISUBSV
14146         DO 260 J=11,80
14147           VINT(J)=VINTSV(J)
14148   260   CONTINUE
14149       ENDIF
14150
14151 C...Format statements for printout.
14152  5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14153      &'actions for MSTP(82) =',I2,' ******')
14154  5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14155      &D9.2,' mb: rejected')
14156  5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14157      &D9.2,' mb: accepted')
14158
14159       RETURN
14160       END
14161
14162 C*********************************************************************
14163
14164 C...PYREMN
14165 C...Adds on target remnants (one or two from each side) and
14166 C...includes primordial kT for hadron beams.
14167
14168       SUBROUTINE PYREMN(IPU1,IPU2)
14169
14170 C...Double precision and integer declarations.
14171       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14172       IMPLICIT INTEGER(I-N)
14173       INTEGER PYK,PYCHGE,PYCOMP
14174 C...Commonblocks.
14175       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14176       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14177       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14178       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14179       COMMON/PYINT1/MINT(400),VINT(400)
14180       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14181 C...Local arrays.
14182       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14183      &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14184
14185 C...Find event type and remaining energy.
14186       ISUB=MINT(1)
14187       NS=N
14188       IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14189         VINT(143)=1D0-VINT(141)
14190         VINT(144)=1D0-VINT(142)
14191       ENDIF
14192
14193 C...Define initial partons.
14194       NTRY=0
14195   100 NTRY=NTRY+1
14196       DO 130 JT=1,2
14197         I=MINT(83)+JT+2
14198         IF(JT.EQ.1) IPU=IPU1
14199         IF(JT.EQ.2) IPU=IPU2
14200         K(I,1)=21
14201         K(I,2)=K(IPU,2)
14202         K(I,3)=I-2
14203         PMS(JT)=0D0
14204         VINT(156+JT)=0D0
14205         VINT(158+JT)=0D0
14206         IF(MINT(47).EQ.1) THEN
14207           DO 110 J=1,5
14208             P(I,J)=P(I-2,J)
14209   110     CONTINUE
14210         ELSEIF(ISUB.EQ.95) THEN
14211           K(I,2)=21
14212         ELSE
14213           P(I,5)=P(IPU,5)
14214
14215 C...No primordial kT, or chosen according to truncated Gaussian or
14216 C...exponential, or (for photon) predetermined or power law.
14217   120     IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14218             IF(MSTP(91).LE.0) THEN
14219               PT=0D0
14220             ELSEIF(MSTP(91).EQ.1) THEN
14221               PT=PARP(91)*SQRT(-LOG(PYR(0)))
14222             ELSE
14223               RPT1=PYR(0)
14224               RPT2=PYR(0)
14225               PT=-PARP(92)*LOG(RPT1*RPT2)
14226             ENDIF
14227             IF(PT.GT.PARP(93)) GOTO 120
14228           ELSEIF(MINT(106+JT).EQ.3) THEN
14229             PTA=SQRT(VINT(282+JT))
14230             PTB=0D0
14231             IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14232               PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14233             ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14234               RPT1=PYR(0)
14235               RPT2=PYR(0)
14236               PTB=-PARP(99)*LOG(RPT1*RPT2)
14237             ENDIF
14238             IF(PTB.GT.PARP(100)) GOTO 120
14239             PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14240             PT=PT*0.8D0**MINT(57)
14241             IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14242           ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14243             IF(MSTP(93).LE.0) THEN
14244               PT=0D0
14245             ELSEIF(MSTP(93).EQ.1) THEN
14246               PT=PARP(99)*SQRT(-LOG(PYR(0)))
14247             ELSEIF(MSTP(93).EQ.2) THEN
14248               RPT1=PYR(0)
14249               RPT2=PYR(0)
14250               PT=-PARP(99)*LOG(RPT1*RPT2)
14251             ELSEIF(MSTP(93).EQ.3) THEN
14252               HA=PARP(99)**2
14253               HB=PARP(100)**2
14254               PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14255             ELSE
14256               HA=PARP(99)**2
14257               HB=PARP(100)**2
14258               IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14259               PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14260             ENDIF
14261             IF(PT.GT.PARP(100)) GOTO 120
14262           ELSE
14263             PT=0D0
14264           ENDIF
14265           VINT(156+JT)=PT
14266           PHI=PARU(2)*PYR(0)
14267           P(I,1)=PT*COS(PHI)
14268           P(I,2)=PT*SIN(PHI)
14269           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14270         ENDIF
14271   130 CONTINUE
14272       IF(MINT(47).EQ.1) RETURN
14273
14274 C...Kinematics construction for initial partons.
14275       I1=MINT(83)+3
14276       I2=MINT(83)+4
14277       IF(ISUB.EQ.95) THEN
14278         SHS=0D0
14279         SHR=0D0
14280       ELSE
14281         SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14282      &  (P(I1,2)+P(I2,2))**2
14283         SHR=SQRT(MAX(0D0,SHS))
14284         IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14285         P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14286         P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14287         P(I2,4)=SHR-P(I1,4)
14288         P(I2,3)=-P(I1,3)
14289
14290 C...Transform partons to overall CM-frame.
14291         ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14292         ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14293         CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14294         ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14295         CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14296         ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14297         CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14298         CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14299         CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14300         ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14301         CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14302       ENDIF
14303
14304 C...Optionally fix up x and Q2 definitions for leptoproduction.
14305       IDISXQ=0
14306       IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14307      &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14308       IF(IDISXQ.EQ.1) THEN
14309
14310 C...Find where incoming and outgoing leptons/partons are sitting.
14311         LESD=1
14312         IF(MINT(42).EQ.1) LESD=2
14313         LPIN=MINT(83)+3-LESD
14314         LEIN=MINT(84)+LESD
14315         LQIN=MINT(84)+3-LESD
14316         LEOUT=MINT(84)+2+LESD
14317         LQOUT=MINT(84)+5-LESD
14318         IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14319         IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14320         LSCMS=0
14321         DO 140 I=MINT(84)+5,N
14322           IF(K(I,2).EQ.94) THEN
14323             LSCMS=I
14324             LEOUT=I+LESD
14325             LQOUT=I+3-LESD
14326           ENDIF
14327   140   CONTINUE
14328         LQBG=IPU1
14329         IF(LESD.EQ.1) LQBG=IPU2
14330
14331 C...Calculate actual and wanted momentum transfer.
14332         XNOM=VINT(43-LESD)
14333         Q2NOM=-VINT(45)
14334         HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14335      &  P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14336      &  (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14337         HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14338         FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14339         P(N+1,1)=FAC*P(LEOUT,1)
14340         P(N+1,2)=FAC*P(LEOUT,2)
14341         P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14342      &  Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14343         P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14344      &  P(N+1,3)**2)
14345         DO 150 J=1,4
14346           QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14347           QNEW(J)=P(LEIN,J)-P(N+1,J)
14348   150   CONTINUE
14349
14350 C...Boost outgoing electron and daughters.
14351         IF(LSCMS.EQ.0) THEN
14352           DO 160 J=1,4
14353             P(LEOUT,J)=P(N+1,J)
14354   160     CONTINUE
14355         ELSE
14356           DO 170 J=1,3
14357             P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14358   170     CONTINUE
14359           PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14360           DO 180 J=1,3
14361             DBE(J)=PINV*P(N+2,J)
14362   180     CONTINUE
14363           DO 200 I=LSCMS+1,N
14364             IORIG=I
14365   190       IORIG=K(IORIG,3)
14366             IF(IORIG.GT.LEOUT) GOTO 190
14367             IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14368      &      CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14369   200     CONTINUE
14370         ENDIF
14371
14372 C...Copy shower initiator and all outgoing partons.
14373         NCOP=N+1
14374         K(NCOP,3)=LQBG
14375         DO 210 J=1,5
14376           P(NCOP,J)=P(LQBG,J)
14377   210   CONTINUE
14378         DO 240 I=MINT(84)+1,N
14379           ICOP=0
14380           IF(K(I,1).GT.10) GOTO 240
14381           IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14382             ICOP=I
14383           ELSE
14384             IORIG=I
14385   220       IORIG=K(IORIG,3)
14386             IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14387               ICOP=IORIG
14388             ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14389               GOTO 220
14390             ENDIF
14391           ENDIF
14392           IF(ICOP.NE.0) THEN
14393             NCOP=NCOP+1
14394             K(NCOP,3)=I
14395             DO 230 J=1,5
14396               P(NCOP,J)=P(I,J)
14397   230       CONTINUE
14398           ENDIF
14399   240   CONTINUE
14400
14401 C...Calculate relative rescaling factors.
14402         SLC=3-2*LESD
14403         PLCSUM=0D0
14404         DO 250 I=N+2,NCOP
14405           PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14406   250   CONTINUE
14407         DO 260 I=N+2,NCOP
14408           V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14409   260   CONTINUE
14410
14411 C...Transfer extra three-momentum of current.
14412         DO 280 I=N+2,NCOP
14413           DO 270 J=1,3
14414             P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14415   270     CONTINUE
14416           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14417   280   CONTINUE
14418
14419 C...Iterate change of initiator momentum to get energy right.
14420         ITER=0
14421   290   ITER=ITER+1
14422         PEEX=-P(N+1,4)-QNEW(4)
14423         PEMV=-P(N+1,3)/P(N+1,4)
14424         DO 300 I=N+2,NCOP
14425           PEEX=PEEX+P(I,4)
14426           PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14427   300   CONTINUE
14428         IF(ABS(PEMV).LT.1D-10) THEN
14429           MINT(51)=1
14430           MINT(57)=MINT(57)+1
14431           RETURN
14432         ENDIF
14433         PZCH=-PEEX/PEMV
14434         P(N+1,3)=P(N+1,3)+PZCH
14435         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)
14436         DO 310 I=N+2,NCOP
14437           P(I,3)=P(I,3)+V(I,1)*PZCH
14438           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14439   310   CONTINUE
14440         IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14441
14442 C...Modify momenta in event record.
14443         HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14444      &  ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14445         IF(ABS(HBE).GE.1D0) THEN
14446           MINT(51)=1
14447           MINT(57)=MINT(57)+1
14448           RETURN
14449         ENDIF
14450         I=MINT(83)+5-LESD
14451         CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14452         DO 330 I=N+1,NCOP
14453           ICOP=K(I,3)
14454           DO 320 J=1,4
14455             P(ICOP,J)=P(I,J)
14456   320     CONTINUE
14457   330   CONTINUE
14458       ENDIF
14459
14460 C...Check minimum invariant mass of remnant system(s).
14461       PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14462       PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14463       PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14464       PMIN(0)=SQRT(PMS(0))
14465       DO 340 JT=1,2
14466         PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14467         PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14468         PMIN(JT)=0D0
14469         IF(MINT(44+JT).EQ.1) GOTO 340
14470         MINT(105)=MINT(102+JT)
14471         MINT(109)=MINT(106+JT)
14472         CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14473         IF(MINT(51).NE.0) THEN
14474           MINT(57)=MINT(57)+1
14475           RETURN
14476         ENDIF
14477         IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14478         IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14479         IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14480         PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14481      &  P(MINT(83)+JT+2,2)**2)
14482   340 CONTINUE
14483       IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14484      &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14485      &PSYS(2,4))) THEN
14486         MINT(51)=1
14487         MINT(57)=MINT(57)+1
14488         RETURN
14489       ENDIF
14490
14491 C...Loop over two remnants; skip if none there.
14492       I=NS
14493       DO 410 JT=1,2
14494         ISN(JT)=0
14495         IF(MINT(44+JT).EQ.1) GOTO 410
14496         IF(JT.EQ.1) IPU=IPU1
14497         IF(JT.EQ.2) IPU=IPU2
14498
14499 C...Store first remnant parton.
14500         I=I+1
14501         IS(JT)=I
14502         ISN(JT)=1
14503         DO 350 J=1,5
14504           K(I,J)=0
14505           P(I,J)=0D0
14506           V(I,J)=0D0
14507   350   CONTINUE
14508         K(I,1)=1
14509         K(I,2)=KFLSP(JT)
14510         K(I,3)=MINT(83)+JT
14511         P(I,5)=PYMASS(K(I,2))
14512
14513 C...First parton colour connections and kinematics.
14514         KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14515         IF(KCOL.EQ.2) THEN
14516           K(I,1)=3
14517           K(I,4)=MSTU(5)*IPU+IPU
14518           K(I,5)=MSTU(5)*IPU+IPU
14519           K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14520           K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14521         ELSEIF(KCOL.NE.0) THEN
14522           K(I,1)=3
14523           KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14524           K(I,KFLS+3)=IPU
14525           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14526         ENDIF
14527         IF(KFLCH(JT).EQ.0) THEN
14528           P(I,1)=-P(MINT(83)+JT+2,1)
14529           P(I,2)=-P(MINT(83)+JT+2,2)
14530           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14531           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14532           P(I,3)=PSYS(JT,3)
14533           P(I,4)=PSYS(JT,4)
14534
14535 C...When extra remnant parton or hadron: store extra remnant.
14536         ELSE
14537           I=I+1
14538           ISN(JT)=2
14539           DO 360 J=1,5
14540             K(I,J)=0
14541             P(I,J)=0D0
14542             V(I,J)=0D0
14543   360     CONTINUE
14544           K(I,1)=1
14545           K(I,2)=KFLCH(JT)
14546           K(I,3)=MINT(83)+JT
14547           P(I,5)=PYMASS(K(I,2))
14548
14549 C...Find parton colour connections of extra remnant.
14550           KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14551           IF(KCOL.EQ.2) THEN
14552             K(I,1)=3
14553             K(I,4)=MSTU(5)*IPU+IPU
14554             K(I,5)=MSTU(5)*IPU+IPU
14555             K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14556             K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14557           ELSEIF(KCOL.NE.0) THEN
14558             K(I,1)=3
14559             KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14560             K(I,KFLS+3)=IPU
14561             K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14562           ENDIF
14563
14564 C...Relative transverse momentum when two remnants.
14565           LOOP=0
14566   370     LOOP=LOOP+1
14567           CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14568           IF(IABS(MINT(10+JT)).LT.20) THEN
14569             P(I-1,1)=0D0
14570             P(I-1,2)=0D0
14571           ELSE
14572             P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14573             P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14574           ENDIF
14575           PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14576           P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14577           P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14578           PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14579
14580 C...Meson or baryon; photon as meson. For splitup below.
14581           IMB=1
14582           IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14583
14584 C***Relative distribution for electron into two electrons. Temporary!
14585           IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14586      &    THEN
14587             CHI(JT)=PYR(0)
14588
14589 C...Relative distribution of electron energy into electron plus parton.
14590           ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14591             XHRD=VINT(140+JT)
14592             XE=VINT(154+JT)
14593             CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14594
14595 C...Relative distribution of energy for particle into two jets.
14596           ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14597             CHIK=PARP(92+2*IMB)
14598             IF(MSTP(92).LE.1) THEN
14599               IF(IMB.EQ.1) CHI(JT)=PYR(0)
14600               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14601             ELSEIF(MSTP(92).EQ.2) THEN
14602               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14603             ELSEIF(MSTP(92).EQ.3) THEN
14604               CUT=2D0*0.3D0/VINT(1)
14605   380         CHI(JT)=PYR(0)**2
14606               IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14607      &        (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14608             ELSEIF(MSTP(92).EQ.4) THEN
14609               CUT=2D0*0.3D0/VINT(1)
14610               CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14611   390         CHIR=CUT*CUTR**PYR(0)
14612               CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14613               IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14614             ELSE
14615               CUT=2D0*0.3D0/VINT(1)
14616               CUTA=CUT**(1D0-PARP(98))
14617               CUTB=(1D0+CUT)**(1D0-PARP(98))
14618   400         CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
14619               IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
14620      &        (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
14621             ENDIF
14622
14623 C...Relative distribution of energy for particle into jet plus particle.
14624           ELSE
14625             IF(MSTP(94).LE.1) THEN
14626               IF(IMB.EQ.1) CHI(JT)=PYR(0)
14627               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14628               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14629             ELSEIF(MSTP(94).EQ.2) THEN
14630               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
14631               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14632             ELSEIF(MSTP(94).EQ.3) THEN
14633               CALL PYZDIS(1,0,PMS(JT+4),ZZ)
14634               CHI(JT)=ZZ
14635             ELSE
14636               CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
14637               CHI(JT)=ZZ
14638             ENDIF
14639           ENDIF
14640
14641 C...Construct total transverse mass; reject if too large.
14642           CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
14643           PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
14644           IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
14645             IF(LOOP.LT.100) THEN
14646               GOTO 370
14647             ELSE
14648               MINT(51)=1
14649               MINT(57)=MINT(57)+1
14650               RETURN
14651             ENDIF
14652           ENDIF
14653           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14654           VINT(158+JT)=CHI(JT)
14655
14656 C...Subdivide longitudinal momentum according to value selected above.
14657           PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
14658           P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
14659           P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
14660           P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
14661           P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
14662         ENDIF
14663   410 CONTINUE
14664       N=I
14665
14666 C...Check if longitudinal boosts needed - if so pick two systems.
14667       PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
14668      &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
14669       IF(PDEV.LE.1D-6*VINT(1)) RETURN
14670       IF(ISN(1).EQ.0) THEN
14671         IR=0
14672         IL=2
14673       ELSEIF(ISN(2).EQ.0) THEN
14674         IR=1
14675         IL=0
14676       ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
14677         IR=1
14678         IL=2
14679       ELSEIF(VINT(143).GT.0.2D0) THEN
14680         IR=1
14681         IL=0
14682       ELSEIF(VINT(144).GT.0.2D0) THEN
14683         IR=0
14684         IL=2
14685       ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
14686         IR=1
14687         IL=0
14688       ELSE
14689         IR=0
14690         IL=2
14691       ENDIF
14692       IG=3-IR-IL
14693
14694 C...E+-pL wanted for system to be modified.
14695       IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
14696         PPB=VINT(1)
14697         PNB=VINT(1)
14698       ELSE
14699         PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
14700         PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
14701       ENDIF
14702
14703 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
14704       IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
14705         PPB=PPB-(PSYS(0,4)+PSYS(0,3))
14706         PNB=PNB-(PSYS(0,4)-PSYS(0,3))
14707         DO 420 J=1,4
14708           PSYS(0,J)=0D0
14709   420   CONTINUE
14710         DO 450 I=MINT(84)+1,NS
14711           IF(K(I,1).GT.10) GOTO 450
14712           INCL=0
14713           IORIG=I
14714   430     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14715           IORIG=K(IORIG,3)
14716           IF(IORIG.GT.LPIN) GOTO 430
14717           IF(INCL.EQ.0) GOTO 450
14718           DO 440 J=1,4
14719             PSYS(0,J)=PSYS(0,J)+P(I,J)
14720   440     CONTINUE
14721   450   CONTINUE
14722         PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14723         PPB=PPB+(PSYS(0,4)+PSYS(0,3))
14724         PNB=PNB+(PSYS(0,4)-PSYS(0,3))
14725       ENDIF
14726
14727 C...Construct longitudinal boosts.
14728       DPMTB=PPB*PNB
14729       DPMTR=PMS(IR)
14730       DPMTL=PMS(IL)
14731       DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
14732       IF(DSQLAM.LE.1D-6*DPMTB) THEN
14733         MINT(51)=1
14734         MINT(57)=MINT(57)+1
14735         RETURN
14736       ENDIF
14737       DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
14738       DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
14739      &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
14740       DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
14741      &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
14742       DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
14743       DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
14744
14745 C...Perform longitudinal boosts.
14746       IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
14747         P(IS(1),3)=0D0
14748         P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
14749       ELSEIF(IR.EQ.1) THEN
14750         CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
14751       ELSEIF(IDISXQ.EQ.1) THEN
14752         DO 470 I=I1,NS
14753           INCL=0
14754           IORIG=I
14755   460     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14756           IORIG=K(IORIG,3)
14757           IF(IORIG.GT.LPIN) GOTO 460
14758           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
14759   470   CONTINUE
14760       ELSE
14761         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
14762       ENDIF
14763       IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
14764         P(IS(2),3)=0D0
14765         P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
14766       ELSEIF(IL.EQ.2) THEN
14767         CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
14768       ELSEIF(IDISXQ.EQ.1) THEN
14769         DO 490 I=I1,NS
14770           INCL=0
14771           IORIG=I
14772   480     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14773           IORIG=K(IORIG,3)
14774           IF(IORIG.GT.LPIN) GOTO 480
14775           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
14776   490   CONTINUE
14777       ELSE
14778         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
14779       ENDIF
14780
14781 C...Final check that energy-momentum conservation worked.
14782       PESUM=0D0
14783       PZSUM=0D0
14784       DO 500 I=MINT(84)+1,N
14785         IF(K(I,1).GT.10) GOTO 500
14786         PESUM=PESUM+P(I,4)
14787         PZSUM=PZSUM+P(I,3)
14788   500 CONTINUE
14789       PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
14790       IF(PDEV.GT.1D-4*VINT(1)) THEN
14791         MINT(51)=1
14792         MINT(57)=MINT(57)+1
14793         RETURN
14794       ENDIF
14795
14796 C...Calculate rotation and boost from overall CM frame to
14797 C...hadronic CM frame in leptoproduction.
14798       MINT(91)=0
14799       IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
14800         MINT(91)=1
14801         LESD=1
14802         IF(MINT(42).EQ.1) LESD=2
14803         LPIN=MINT(83)+3-LESD
14804
14805 C...Sum upp momenta of everything not lepton or photon to define boost.
14806         DO 510 J=1,4
14807           PSUM(J)=0D0
14808   510   CONTINUE
14809         DO 530 I=1,N
14810           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
14811           IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
14812           IF(K(I,2).EQ.22) GOTO 530
14813           DO 520 J=1,4
14814             PSUM(J)=PSUM(J)+P(I,J)
14815   520     CONTINUE
14816   530   CONTINUE
14817         VINT(223)=-PSUM(1)/PSUM(4)
14818         VINT(224)=-PSUM(2)/PSUM(4)
14819         VINT(225)=-PSUM(3)/PSUM(4)
14820
14821 C...Boost incoming hadron to hadronic CM frame to determine rotations.
14822         K(N+1,1)=1
14823         DO 540 J=1,5
14824           P(N+1,J)=P(LPIN,J)
14825           V(N+1,J)=V(LPIN,J)
14826   540   CONTINUE
14827         CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
14828         VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
14829         CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
14830         IF(LESD.EQ.2) THEN
14831           VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
14832         ELSE
14833           VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
14834         ENDIF
14835       ENDIF
14836
14837       RETURN
14838       END
14839
14840 C*********************************************************************
14841
14842 C...PYDIFF
14843 C...Handles diffractive and elastic scattering.
14844
14845       SUBROUTINE PYDIFF
14846
14847 C...Double precision and integer declarations.
14848       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14849       IMPLICIT INTEGER(I-N)
14850       INTEGER PYK,PYCHGE,PYCOMP
14851 C...Commonblocks.
14852       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14853       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14854       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14855       COMMON/PYINT1/MINT(400),VINT(400)
14856       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
14857
14858 C...Reset K, P and V vectors. Store incoming particles.
14859       DO 110 JT=1,MSTP(126)+10
14860         I=MINT(83)+JT
14861         DO 100 J=1,5
14862           K(I,J)=0
14863           P(I,J)=0D0
14864           V(I,J)=0D0
14865   100   CONTINUE
14866   110 CONTINUE
14867       N=MINT(84)
14868       MINT(3)=0
14869       MINT(21)=0
14870       MINT(22)=0
14871       MINT(23)=0
14872       MINT(24)=0
14873       MINT(4)=4
14874       DO 130 JT=1,2
14875         I=MINT(83)+JT
14876         K(I,1)=21
14877         K(I,2)=MINT(10+JT)
14878         DO 120 J=1,5
14879           P(I,J)=VINT(285+5*JT+J)
14880   120   CONTINUE
14881   130 CONTINUE
14882       MINT(6)=2
14883
14884 C...Subprocess; kinematics.
14885       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
14886       PZ=SQRT(SQLAM)/(2D0*VINT(1))
14887       DO 200 JT=1,2
14888         I=MINT(83)+JT
14889         PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
14890         KFH=MINT(102+JT)
14891
14892 C...Elastically scattered particle. (Except elastic GVMD states.)
14893         IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
14894      &  MINT(106+JT).NE.3)) THEN
14895           N=N+1
14896           K(N,1)=1
14897           K(N,2)=KFH
14898           K(N,3)=I+2
14899           P(N,3)=PZ*(-1)**(JT+1)
14900           P(N,4)=PE
14901           P(N,5)=SQRT(VINT(62+JT))
14902
14903 C...Decay rho from elastic scattering of gamma with sin**2(theta)
14904 C...distribution of decay products (in rho rest frame).
14905           IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
14906             NSAV=N
14907             DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
14908             P(N,3)=0D0
14909             P(N,4)=P(N,5)
14910             CALL PYDECY(NSAV)
14911             IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
14912               PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
14913               CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
14914               THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
14915               CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
14916   140         CTHE=2D0*PYR(0)-1D0
14917               IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
14918               CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
14919             ENDIF
14920             CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
14921           ENDIF
14922
14923 C...Diffracted particle: low-mass system to two particles.
14924         ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
14925           N=N+2
14926           K(N-1,1)=1
14927           K(N,1)=1
14928           K(N-1,3)=I+2
14929           K(N,3)=I+2
14930           PMMAS=SQRT(VINT(62+JT))
14931           NTRY=0
14932   150     NTRY=NTRY+1
14933           IF(NTRY.LT.20) THEN
14934             MINT(105)=MINT(102+JT)
14935             MINT(109)=MINT(106+JT)
14936             CALL PYSPLI(KFH,21,KFL1,KFL2)
14937             CALL PYKFDI(KFL1,0,KFL3,KF1)
14938             IF(KF1.EQ.0) GOTO 150
14939             CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
14940             IF(KF2.EQ.0) GOTO 150
14941           ELSE
14942             KF1=KFH
14943             KF2=111
14944           ENDIF
14945           PM1=PYMASS(KF1)
14946           PM2=PYMASS(KF2)
14947           IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
14948           K(N-1,2)=KF1
14949           K(N,2)=KF2
14950           P(N-1,5)=PM1
14951           P(N,5)=PM2
14952           PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
14953      &    4D0*PM1**2*PM2**2))/(2D0*PMMAS)
14954           P(N-1,3)=PZP
14955           P(N,3)=-PZP
14956           P(N-1,4)=SQRT(PM1**2+PZP**2)
14957           P(N,4)=SQRT(PM2**2+PZP**2)
14958           CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
14959      &    0D0,0D0,0D0)
14960           DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
14961           CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
14962
14963 C...Diffracted particle: valence quark kicked out.
14964         ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
14965      &    PARP(101))) THEN
14966           N=N+2
14967           K(N-1,1)=2
14968           K(N,1)=1
14969           K(N-1,3)=I+2
14970           K(N,3)=I+2
14971           MINT(105)=MINT(102+JT)
14972           MINT(109)=MINT(106+JT)
14973           CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
14974           P(N-1,5)=PYMASS(K(N-1,2))
14975           P(N,5)=PYMASS(K(N,2))
14976           SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
14977      &    4D0*P(N-1,5)**2*P(N,5)**2
14978           P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
14979      &    P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
14980           P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
14981           P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
14982           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
14983
14984 C...Diffracted particle: gluon kicked out.
14985         ELSE
14986           N=N+3
14987           K(N-2,1)=2
14988           K(N-1,1)=2
14989           K(N,1)=1
14990           K(N-2,3)=I+2
14991           K(N-1,3)=I+2
14992           K(N,3)=I+2
14993           MINT(105)=MINT(102+JT)
14994           MINT(109)=MINT(106+JT)
14995           CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
14996           K(N-1,2)=21
14997           P(N-2,5)=PYMASS(K(N-2,2))
14998           P(N-1,5)=0D0
14999           P(N,5)=PYMASS(K(N,2))
15000 C...Energy distribution for particle into two jets.
15001   160     IMB=1
15002           IF(MOD(KFH/1000,10).NE.0) IMB=2
15003           CHIK=PARP(92+2*IMB)
15004           IF(MSTP(92).LE.1) THEN
15005             IF(IMB.EQ.1) CHI=PYR(0)
15006             IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15007           ELSEIF(MSTP(92).EQ.2) THEN
15008             CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15009           ELSEIF(MSTP(92).EQ.3) THEN
15010             CUT=2D0*0.3D0/VINT(1)
15011   170       CHI=PYR(0)**2
15012             IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15013      &      PYR(0)) GOTO 170
15014           ELSEIF(MSTP(92).EQ.4) THEN
15015             CUT=2D0*0.3D0/VINT(1)
15016             CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15017   180       CHIR=CUT*CUTR**PYR(0)
15018             CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15019             IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15020           ELSE
15021             CUT=2D0*0.3D0/VINT(1)
15022             CUTA=CUT**(1D0-PARP(98))
15023             CUTB=(1D0+CUT)**(1D0-PARP(98))
15024   190       CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15025             IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15026      &      (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15027           ENDIF
15028           IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15029      &    VINT(62+JT)) GOTO 160
15030           SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15031           PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15032      &    (2D0*VINT(62+JT))
15033           PEI=SQRT(PZI**2+SQM)
15034           PQQP=(1D0-CHI)*(PEI+PZI)
15035           P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15036           P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15037           P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15038           P(N-1,3)=P(N-1,4)*(-1)**JT
15039           P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15040           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15041         ENDIF
15042
15043 C...Documentation lines.
15044         K(I+2,1)=21
15045         IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15046         IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15047      &  MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15048         K(I+2,3)=I
15049         P(I+2,3)=PZ*(-1)**(JT+1)
15050         P(I+2,4)=PE
15051         P(I+2,5)=SQRT(VINT(62+JT))
15052   200 CONTINUE
15053
15054 C...Rotate outgoing partons/particles using cos(theta).
15055       IF(VINT(23).LT.0.9D0) THEN
15056         CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15057       ELSE
15058         CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15059       ENDIF
15060
15061       RETURN
15062       END
15063
15064 C*********************************************************************
15065
15066 C...PYDISG
15067 C...Set up a DIS process as gamma* + f -> f, with beam remnant
15068 C...and showering added consecutively. Photon flux by the PYGAGA
15069 C...routine (if at all).
15070
15071       SUBROUTINE PYDISG
15072
15073 C...Double precision and integer declarations.
15074       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15075       IMPLICIT INTEGER(I-N)
15076       INTEGER PYK,PYCHGE,PYCOMP
15077 C...Parameter statement to help give large particle numbers.
15078       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15079      &KEXCIT=4000000,KDIMEN=5000000)
15080 C...Commonblocks.
15081       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15082       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15083       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15084       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15085       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15086       COMMON/PYINT1/MINT(400),VINT(400)
15087       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15088 C...Local arrays.
15089       DIMENSION PMS(4)
15090
15091 C...Choice of subprocess, number of documentation lines
15092       IDOC=7
15093       MINT(3)=IDOC-6
15094       MINT(4)=IDOC
15095       IPU1=MINT(84)+1
15096       IPU2=MINT(84)+2
15097       IPU3=MINT(84)+3
15098       ISIDE=1
15099       IF(MINT(107).EQ.4) ISIDE=2
15100
15101 C...Reset K, P and V vectors. Store incoming particles
15102       DO 110 JT=1,MSTP(126)+20
15103         I=MINT(83)+JT
15104         DO 100 J=1,5
15105           K(I,J)=0
15106           P(I,J)=0D0
15107           V(I,J)=0D0
15108   100   CONTINUE
15109   110 CONTINUE
15110       DO 130 JT=1,2
15111         I=MINT(83)+JT
15112         K(I,1)=21
15113         K(I,2)=MINT(10+JT)
15114         DO 120 J=1,5
15115           P(I,J)=VINT(285+5*JT+J)
15116   120   CONTINUE
15117   130 CONTINUE
15118       MINT(6)=2
15119
15120 C...Store incoming partons in hadronic CM-frame
15121       DO 140 JT=1,2
15122         I=MINT(84)+JT
15123         K(I,1)=14
15124         K(I,2)=MINT(14+JT)
15125         K(I,3)=MINT(83)+2+JT
15126   140 CONTINUE
15127       IF(MINT(15).EQ.22) THEN
15128         P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15129         P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15130         P(MINT(84)+1,5)=-SQRT(VINT(307))
15131         P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15132         P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15133         KFRES=MINT(16)
15134         ISIDE=2
15135       ELSE
15136         P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15137         P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15138         P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15139         P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15140         P(MINT(84)+1,5)=-SQRT(VINT(308))
15141         KFRES=MINT(15)
15142         ISIDE=1
15143       ENDIF
15144       SIDESG=(-1D0)**(ISIDE-1)
15145
15146 C...Copy incoming partons to documentation lines.
15147       DO 170 JT=1,2
15148         I1=MINT(83)+4+JT
15149         I2=MINT(84)+JT
15150         K(I1,1)=21
15151         K(I1,2)=K(I2,2)
15152         K(I1,3)=I1-2
15153         DO 150 J=1,5
15154           P(I1,J)=P(I2,J)
15155   150   CONTINUE
15156
15157 C...Second copy for partons before ISR shower, since no such.
15158         I1=MINT(83)+2+JT
15159         K(I1,1)=21
15160         K(I1,2)=K(I2,2)
15161         K(I1,3)=I1-2
15162         DO 160 J=1,5
15163           P(I1,J)=P(I2,J)
15164   160   CONTINUE
15165   170 CONTINUE
15166
15167 C...Define initial partons.
15168       NTRY=0
15169   180 NTRY=NTRY+1
15170       IF(NTRY.GT.100) THEN
15171         MINT(51)=1
15172         RETURN
15173       ENDIF
15174
15175 C...Scattered quark in hadronic CM frame.
15176       I=MINT(83)+7
15177       K(IPU3,1)=3
15178       K(IPU3,2)=KFRES
15179       K(IPU3,3)=I
15180       P(IPU3,5)=PYMASS(KFRES)
15181       P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15182       P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15183       P(IPU3,5)=0D0
15184       K(I,1)=21
15185       K(I,2)=KFRES
15186       K(I,3)=MINT(83)+4+ISIDE
15187       P(I,3)=P(IPU3,3)
15188       P(I,4)=P(IPU3,4)
15189       P(I,5)=P(IPU3,5)
15190       N=IPU3
15191       MINT(21)=KFRES
15192       MINT(22)=0
15193
15194 C...No primordial kT, or chosen according to truncated Gaussian or
15195 C...exponential, or (for photon) predetermined or power law.
15196   190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15197         IF(MSTP(91).LE.0) THEN
15198           PT=0D0
15199         ELSEIF(MSTP(91).EQ.1) THEN
15200           PT=PARP(91)*SQRT(-LOG(PYR(0)))
15201         ELSE
15202           RPT1=PYR(0)
15203           RPT2=PYR(0)
15204           PT=-PARP(92)*LOG(RPT1*RPT2)
15205         ENDIF
15206         IF(PT.GT.PARP(93)) GOTO 190
15207       ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15208         PTA=SQRT(VINT(282+ISIDE))
15209         PTB=0D0
15210         IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15211           PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15212         ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15213           RPT1=PYR(0)
15214           RPT2=PYR(0)
15215           PTB=-PARP(99)*LOG(RPT1*RPT2)
15216         ENDIF
15217         IF(PTB.GT.PARP(100)) GOTO 190
15218         PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15219         IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15220       ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15221         IF(MSTP(93).LE.0) THEN
15222           PT=0D0
15223         ELSEIF(MSTP(93).EQ.1) THEN
15224           PT=PARP(99)*SQRT(-LOG(PYR(0)))
15225         ELSEIF(MSTP(93).EQ.2) THEN
15226           RPT1=PYR(0)
15227           RPT2=PYR(0)
15228           PT=-PARP(99)*LOG(RPT1*RPT2)
15229         ELSEIF(MSTP(93).EQ.3) THEN
15230           HA=PARP(99)**2
15231           HB=PARP(100)**2
15232           PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15233         ELSE
15234           HA=PARP(99)**2
15235           HB=PARP(100)**2
15236           IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15237           PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15238         ENDIF
15239         IF(PT.GT.PARP(100)) GOTO 190
15240       ELSE
15241         PT=0D0
15242       ENDIF
15243       VINT(156+ISIDE)=PT
15244       PHI=PARU(2)*PYR(0)
15245       P(IPU3,1)=PT*COS(PHI)
15246       P(IPU3,2)=PT*SIN(PHI)
15247       P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15248       PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15249       PCP=P(IPU3,4)+ABS(P(IPU3,3))
15250
15251 C...Find one or two beam remnants.
15252       MINT(105)=MINT(102+ISIDE)
15253       MINT(109)=MINT(106+ISIDE)
15254       CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15255       IF(MINT(51).NE.0) THEN
15256         MINT(51)=0
15257         GOTO 180
15258       ENDIF
15259
15260 C...Store first remnant parton, with colour info and kinematics.
15261       I=N+1
15262       K(I,1)=1
15263       K(I,2)=KFLSP
15264       K(I,3)=MINT(83)+ISIDE
15265       P(I,5)=PYMASS(K(I,2))
15266       KCOL=KCHG(PYCOMP(KFLSP),2)
15267       IF(KCOL.NE.0) THEN
15268         K(I,1)=3
15269         KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15270         K(I,KFLS+3)=MSTU(5)*IPU3
15271         K(IPU3,6-KFLS)=MSTU(5)*I
15272         ICOLR=I
15273       ENDIF
15274       IF(KFLCH.EQ.0) THEN
15275         P(I,1)=-P(IPU3,1)
15276         P(I,2)=-P(IPU3,2)
15277         PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15278         P(I,3)=-P(IPU3,3)
15279         P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15280         PRP=P(I,4)+ABS(P(I,3))
15281
15282 C...When extra remnant parton or hadron: store extra remnant.
15283       ELSE
15284         I=I+1
15285         K(I,1)=1
15286         K(I,2)=KFLCH
15287         K(I,3)=MINT(83)+ISIDE
15288         P(I,5)=PYMASS(K(I,2))
15289         KCOL=KCHG(PYCOMP(KFLCH),2)
15290         IF(KCOL.NE.0) THEN
15291           K(I,1)=3
15292           KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15293           K(I,KFLS+3)=MSTU(5)*IPU3
15294           K(IPU3,6-KFLS)=MSTU(5)*I
15295           ICOLR=I
15296         ENDIF
15297
15298 C...Relative transverse momentum when two remnants.
15299         LOOP=0
15300   200   LOOP=LOOP+1
15301         CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15302         P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15303         P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15304         PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15305         P(I,1)=-P(IPU3,1)-P(I-1,1)
15306         P(I,2)=-P(IPU3,2)-P(I-1,2)
15307         PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15308
15309 C...Relative distribution of energy for particle into jet plus particle.
15310         IMB=1
15311         IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15312         IF(MSTP(94).LE.1) THEN
15313           IF(IMB.EQ.1) CHI=PYR(0)
15314           IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15315           IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15316         ELSEIF(MSTP(94).EQ.2) THEN
15317           CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15318           IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15319         ELSEIF(MSTP(94).EQ.3) THEN
15320           CALL PYZDIS(1,0,PMS(4),ZZ)
15321           CHI=ZZ
15322         ELSE
15323           CALL PYZDIS(1000,0,PMS(4),ZZ)
15324           CHI=ZZ
15325         ENDIF
15326
15327 C...Construct total transverse mass; reject if too large.
15328         CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15329         PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15330         IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15331           IF(LOOP.LT.10) GOTO 200
15332           GOTO 180
15333         ENDIF
15334         VINT(158+ISIDE)=CHI
15335
15336 C...Subdivide longitudinal momentum according to value selected above.
15337         PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15338         PW1=(1D0-CHI)*PRP
15339         P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15340         P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15341         PW2=CHI*PRP
15342         P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15343         P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15344       ENDIF
15345       N=I
15346
15347 C...Boost current and remnant systems to correct frame.
15348       IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15349       DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15350       DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15351      &(2D0*VINT(1)*PCP)
15352       DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15353      &(2D0*VINT(1)*PRP)
15354       DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15355       DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15356       CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15357       CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15358
15359 C...Let current quark shower; recoil but no showering by colour partner.
15360       QMAX=2D0*SQRT(VINT(309-ISIDE))
15361       MSTJ48=MSTJ(48)
15362       MSTJ(48)=1
15363       PARJ86=PARJ(86)
15364       PARJ(86)=0D0
15365       IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15366       MSTJ(48)=MSTJ48
15367       PARJ(86)=PARJ86
15368
15369       RETURN
15370       END
15371
15372 C*********************************************************************
15373
15374 C...PYDOCU
15375 C...Handles the documentation of the process in MSTI and PARI,
15376 C...and also computes cross-sections based on accumulated statistics.
15377
15378       SUBROUTINE PYDOCU
15379
15380 C...Double precision and integer declarations.
15381       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15382       IMPLICIT INTEGER(I-N)
15383       INTEGER PYK,PYCHGE,PYCOMP
15384 C...Commonblocks.
15385       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15386       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15387       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15388       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15389       COMMON/PYINT1/MINT(400),VINT(400)
15390       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15391       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15392       SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15393      &/PYINT5/
15394
15395 C...Calculate Monte Carlo estimates of cross-sections.
15396       ISUB=MINT(1)
15397       IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15398       NGEN(0,3)=NGEN(0,3)+1
15399       XSEC(0,3)=0D0
15400       DO 100 I=1,500
15401         IF(I.EQ.96.OR.I.EQ.97) THEN
15402           XSEC(I,3)=0D0
15403         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15404      &    I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15405           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15406      &    DBLE(NGEN(96,2)))
15407         ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15408           XSEC(I,3)=0D0
15409         ELSEIF(NGEN(I,2).EQ.0) THEN
15410           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15411      &    DBLE(NGEN(0,2)))
15412         ELSE
15413           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15414      &    DBLE(NGEN(I,2)))
15415         ENDIF
15416         XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15417   100 CONTINUE
15418
15419 C...Rescale to known low-pT cross-section for standard QCD processes.
15420       IF(MSUB(95).EQ.1) THEN
15421         XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15422      &  XSEC(68,3)+XSEC(95,3)
15423         XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15424         IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15425           FAC=XSECW/XSECH
15426           XSEC(11,3)=FAC*XSEC(11,3)
15427           XSEC(12,3)=FAC*XSEC(12,3)
15428           XSEC(13,3)=FAC*XSEC(13,3)
15429           XSEC(28,3)=FAC*XSEC(28,3)
15430           XSEC(53,3)=FAC*XSEC(53,3)
15431           XSEC(68,3)=FAC*XSEC(68,3)
15432           XSEC(95,3)=FAC*XSEC(95,3)
15433           XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15434         ENDIF
15435       ENDIF
15436
15437 C...Save information for gamma-p and gamma-gamma.
15438       IF(MINT(121).GT.1) THEN
15439         IGA=MINT(122)
15440         CALL PYSAVE(2,IGA)
15441         CALL PYSAVE(5,0)
15442       ENDIF
15443
15444 C...Reset information on hard interaction.
15445       DO 110 J=1,200
15446         MSTI(J)=0
15447         PARI(J)=0D0
15448   110 CONTINUE
15449
15450 C...Copy integer valued information from MINT into MSTI.
15451       DO 120 J=1,32
15452         MSTI(J)=MINT(J)
15453   120 CONTINUE
15454       IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15455
15456 C...Store cross-section variables in PARI.
15457       PARI(1)=XSEC(0,3)
15458       PARI(2)=XSEC(0,3)/MINT(5)
15459       PARI(7)=VINT(97)
15460       PARI(9)=VINT(99)
15461       PARI(10)=VINT(100)
15462       VINT(98)=VINT(98)+VINT(100)
15463       IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15464
15465 C...Store kinematics variables in PARI.
15466       PARI(11)=VINT(1)
15467       PARI(12)=VINT(2)
15468       IF(ISUB.NE.95) THEN
15469         DO 130 J=13,26
15470           PARI(J)=VINT(30+J)
15471   130   CONTINUE
15472         PARI(31)=VINT(141)
15473         PARI(32)=VINT(142)
15474         PARI(33)=VINT(41)
15475         PARI(34)=VINT(42)
15476         PARI(35)=PARI(33)-PARI(34)
15477         PARI(36)=VINT(21)
15478         PARI(37)=VINT(22)
15479         PARI(38)=VINT(26)
15480         PARI(39)=VINT(157)
15481         PARI(40)=VINT(158)
15482         PARI(41)=VINT(23)
15483         PARI(42)=2D0*VINT(47)/VINT(1)
15484       ENDIF
15485
15486 C...Store information on scattered partons in PARI.
15487       IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15488         DO 140 IS=7,8
15489           I=MINT(IS)
15490           PARI(36+IS)=P(I,3)/VINT(1)
15491           PARI(38+IS)=P(I,4)/VINT(1)
15492           PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15493           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15494      &    SQRT(PR),1D20)),P(I,3))
15495           PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15496           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15497      &    SQRT(PR),1D20)),P(I,3))
15498           PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15499           PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15500           PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15501   140   CONTINUE
15502       ENDIF
15503
15504 C...Store sum up transverse and longitudinal momenta.
15505       PARI(65)=2D0*PARI(17)
15506       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15507         DO 150 I=MSTP(126)+1,N
15508           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15509           PT=SQRT(P(I,1)**2+P(I,2)**2)
15510           PARI(69)=PARI(69)+PT
15511           IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15512           IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15513   150   CONTINUE
15514         PARI(67)=PARI(68)
15515         PARI(71)=VINT(151)
15516         PARI(72)=VINT(152)
15517         PARI(73)=VINT(151)
15518         PARI(74)=VINT(152)
15519       ELSE
15520         PARI(66)=PARI(65)
15521         PARI(69)=PARI(65)
15522       ENDIF
15523
15524 C...Store various other pieces of information into PARI.
15525       PARI(61)=VINT(148)
15526       PARI(75)=VINT(155)
15527       PARI(76)=VINT(156)
15528       PARI(77)=VINT(159)
15529       PARI(78)=VINT(160)
15530       PARI(81)=VINT(138)
15531
15532 C...Store information on lepton -> lepton + gamma in PYGAGA.
15533       MSTI(71)=MINT(141)
15534       MSTI(72)=MINT(142)
15535       PARI(101)=VINT(301)
15536       PARI(102)=VINT(302)
15537       DO 160 I=103,114
15538         PARI(I)=VINT(I+202)
15539   160 CONTINUE
15540
15541 C...Set information for PYTABU.
15542       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15543         MSTU(161)=MINT(21)
15544         MSTU(162)=0
15545       ELSEIF(ISET(ISUB).EQ.5) THEN
15546         MSTU(161)=MINT(23)
15547         MSTU(162)=0
15548       ELSE
15549         MSTU(161)=MINT(21)
15550         MSTU(162)=MINT(22)
15551       ENDIF
15552
15553       RETURN
15554       END
15555
15556 C*********************************************************************
15557
15558 C...PYFRAM
15559 C...Performs transformations between different coordinate frames.
15560
15561       SUBROUTINE PYFRAM(IFRAME)
15562
15563 C...Double precision and integer declarations.
15564       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15565       IMPLICIT INTEGER(I-N)
15566       INTEGER PYK,PYCHGE,PYCOMP
15567 C...Commonblocks.
15568       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15569       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15570       COMMON/PYINT1/MINT(400),VINT(400)
15571       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15572
15573 C...Check that transformation can and should be done.
15574       IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15575      &MINT(91).EQ.1)) THEN
15576         IF(IFRAME.EQ.MINT(6)) RETURN
15577       ELSE
15578         WRITE(MSTU(11),5000) IFRAME,MINT(6)
15579         RETURN
15580       ENDIF
15581
15582       IF(MINT(6).EQ.1) THEN
15583 C...Transform from fixed target or user specified frame to
15584 C...overall CM frame.
15585         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15586         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15587         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15588       ELSEIF(MINT(6).EQ.3) THEN
15589 C...Transform from hadronic CM frame in DIS to overall CM frame.
15590         CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15591      &  -VINT(225))
15592       ENDIF
15593
15594       IF(IFRAME.EQ.1) THEN
15595 C...Transform from overall CM frame to fixed target or user specified
15596 C...frame.
15597         CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15598       ELSEIF(IFRAME.EQ.3) THEN
15599 C...Transform from overall CM frame to hadronic CM frame in DIS.
15600         CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15601         CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15602         CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15603       ENDIF
15604
15605 C...Set information about new frame.
15606       MINT(6)=IFRAME
15607       MSTI(6)=IFRAME
15608
15609  5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15610      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15611      &1X,I5)
15612
15613       RETURN
15614       END
15615
15616 C*********************************************************************
15617
15618 C...PYWIDT
15619 C...Calculates full and partial widths of resonances.
15620
15621       SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
15622
15623 C...Double precision and integer declarations.
15624       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15625       IMPLICIT INTEGER(I-N)
15626       INTEGER PYK,PYCHGE,PYCOMP
15627 C...Parameter statement to help give large particle numbers.
15628       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15629      &KEXCIT=4000000,KDIMEN=5000000)
15630 C...Commonblocks.
15631       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15632       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15633       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15634       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15635       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15636       COMMON/PYINT1/MINT(400),VINT(400)
15637       COMMON/PYINT4/MWID(500),WIDS(500,5)
15638       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
15639       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15640      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
15641       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
15642      &/PYINT4/,/PYMSSM/,/PYSSMT/
15643 C...Local arrays and saved variables.
15644       COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
15645       DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
15646      &WID2SV(3,2),WDTPP(0:300),WDTEP(0:300,0:5)
15647       SAVE MOFSV,WIDWSV,WID2SV
15648       DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
15649
15650 C...Compressed code and sign; mass.
15651       KFLA=IABS(KFLR)
15652       KFLS=ISIGN(1,KFLR)
15653       KC=PYCOMP(KFLA)
15654       SHR=SQRT(SH)
15655       PMR=PMAS(KC,1)
15656
15657 C...Reset width information.
15658       DO 110 I=0,200
15659         WDTP(I)=0D0
15660         DO 100 J=0,5
15661           WDTE(I,J)=0D0
15662   100   CONTINUE
15663   110 CONTINUE
15664
15665 C...Allow for fudge factor to rescale resonance width.
15666       FUDGE=1D0
15667       IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
15668      &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
15669         IF(MSTP(110).EQ.KFLA) THEN
15670           FUDGE=PARP(110)
15671         ELSEIF(MSTP(110).EQ.-1) THEN
15672           IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
15673         ELSEIF(MSTP(110).EQ.-2) THEN
15674           FUDGE=PARP(110)
15675         ENDIF
15676       ENDIF
15677
15678 C...Not to be treated as a resonance: return.
15679       IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
15680      &KFLA.NE.22) THEN
15681         WDTP(0)=1D0
15682         WDTE(0,0)=1D0
15683         MINT(61)=0
15684         MINT(62)=0
15685         MINT(63)=0
15686         RETURN
15687
15688 C...Treatment as a resonance based on tabulated branching ratios.
15689       ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
15690 C...Loop over possible decay channels; skip irrelevant ones.
15691         DO 120 I=1,MDCY(KC,3)
15692           IDC=I+MDCY(KC,2)-1
15693           IF(MDME(IDC,1).LT.0) GOTO 120
15694
15695 C...Read out decay products and nominal masses.
15696           KFD1=KFDP(IDC,1)
15697           KFC1=PYCOMP(KFD1)
15698           IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
15699           PM1=PMAS(KFC1,1)
15700           KFD2=KFDP(IDC,2)
15701           KFC2=PYCOMP(KFD2)
15702           IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
15703           PM2=PMAS(KFC2,1)
15704           KFD3=KFDP(IDC,3)
15705           PM3=0D0
15706           IF(KFD3.NE.0) THEN
15707             KFC3=PYCOMP(KFD3)
15708             IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
15709             PM3=PMAS(KFC3,1)
15710           ENDIF
15711
15712 C...Naive partial width and alternative threshold factors.
15713           WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
15714           IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
15715      &    PM1+PM2+PM3.GE.SHR) THEN
15716              WDTP(I)=0D0
15717           ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
15718             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
15719      &      4D0*PM1**2*PM2**2))/SH
15720           ELSEIF(MDME(IDC,2).EQ.52) THEN
15721             PMA=MAX(PM1,PM2,PM3)
15722             PMC=MIN(PM1,PM2,PM3)
15723             PMB=PM1+PM2+PM3-PMA-PMC
15724             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
15725             PMAN=PMA**2/SH
15726             PMBN=PMB**2/SH
15727             PMCN=PMC**2/SH
15728             PMBCN=PMBC**2/SH
15729             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
15730      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15731      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15732      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
15733      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15734      &      ((1D0-PMBCN)*PMBCN*SH)
15735           ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
15736             WDTP(I)=WDTP(I)*SQRT(
15737      &      MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
15738      &      MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
15739           ELSEIF(MDME(IDC,2).EQ.53) THEN
15740             PMA=MAX(PM1,PM2,PM3)
15741             PMC=MIN(PM1,PM2,PM3)
15742             PMB=PM1+PM2+PM3-PMA-PMC
15743             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
15744             PMAN=PMA**2/SH
15745             PMBN=PMB**2/SH
15746             PMCN=PMC**2/SH
15747             PMBCN=PMBC**2/SH
15748             FACACT=SQRT(MAX(0D0,
15749      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15750      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15751      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
15752      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15753      &      ((1D0-PMBCN)*PMBCN*SH)
15754             PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
15755             PMAN=PMA**2/PMR**2
15756             PMBN=PMB**2/PMR**2
15757             PMCN=PMC**2/PMR**2
15758             PMBCN=PMBC**2/PMR**2
15759             FACNOM=SQRT(MAX(0D0,
15760      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15761      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15762      &      ((PMR-PMA)**2-(PMB+PMC)**2)*
15763      &      (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
15764      &      ((1D0-PMBCN)*PMBCN*PMR**2)
15765             WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
15766           ENDIF
15767           WDTP(I)=FUDGE*WDTP(I)
15768           WDTP(0)=WDTP(0)+WDTP(I)
15769
15770 C...Calculate secondary width (at most two identical/opposite).
15771           WID2=1D0
15772           IF(MDME(IDC,1).GT.0) THEN
15773             IF(KFD2.EQ.KFD1) THEN
15774               IF(KCHG(KFC1,3).EQ.0) THEN
15775                 WID2=WIDS(KFC1,1)
15776               ELSEIF(KFD1.GT.0) THEN
15777                 WID2=WIDS(KFC1,4)
15778               ELSE
15779                 WID2=WIDS(KFC1,5)
15780               ENDIF
15781               IF(KFD3.GT.0) THEN
15782                 WID2=WID2*WIDS(KFC3,2)
15783               ELSEIF(KFD3.LT.0) THEN
15784                 WID2=WID2*WIDS(KFC3,3)
15785               ENDIF
15786             ELSEIF(KFD2.EQ.-KFD1) THEN
15787               WID2=WIDS(KFC1,1)
15788               IF(KFD3.GT.0) THEN
15789                 WID2=WID2*WIDS(KFC3,2)
15790               ELSEIF(KFD3.LT.0) THEN
15791                 WID2=WID2*WIDS(KFC3,3)
15792               ENDIF
15793             ELSEIF(KFD3.EQ.KFD1) THEN
15794               IF(KCHG(KFC1,3).EQ.0) THEN
15795                 WID2=WIDS(KFC1,1)
15796               ELSEIF(KFD1.GT.0) THEN
15797                 WID2=WIDS(KFC1,4)
15798               ELSE
15799                 WID2=WIDS(KFC1,5)
15800               ENDIF
15801               IF(KFD2.GT.0) THEN
15802                 WID2=WID2*WIDS(KFC2,2)
15803               ELSEIF(KFD2.LT.0) THEN
15804                 WID2=WID2*WIDS(KFC2,3)
15805               ENDIF
15806             ELSEIF(KFD3.EQ.-KFD1) THEN
15807               WID2=WIDS(KFC1,1)
15808               IF(KFD2.GT.0) THEN
15809                 WID2=WID2*WIDS(KFC2,2)
15810               ELSEIF(KFD2.LT.0) THEN
15811                 WID2=WID2*WIDS(KFC2,3)
15812               ENDIF
15813             ELSEIF(KFD3.EQ.KFD2) THEN
15814               IF(KCHG(KFC2,3).EQ.0) THEN
15815                 WID2=WIDS(KFC2,1)
15816               ELSEIF(KFD2.GT.0) THEN
15817                 WID2=WIDS(KFC2,4)
15818               ELSE
15819                 WID2=WIDS(KFC2,5)
15820               ENDIF
15821               IF(KFD1.GT.0) THEN
15822                 WID2=WID2*WIDS(KFC1,2)
15823               ELSEIF(KFD1.LT.0) THEN
15824                 WID2=WID2*WIDS(KFC1,3)
15825               ENDIF
15826             ELSEIF(KFD3.EQ.-KFD2) THEN
15827               WID2=WIDS(KFC2,1)
15828               IF(KFD1.GT.0) THEN
15829                 WID2=WID2*WIDS(KFC1,2)
15830               ELSEIF(KFD1.LT.0) THEN
15831                 WID2=WID2*WIDS(KFC1,3)
15832               ENDIF
15833             ELSE
15834               IF(KFD1.GT.0) THEN
15835                 WID2=WIDS(KFC1,2)
15836               ELSE
15837                 WID2=WIDS(KFC1,3)
15838               ENDIF
15839               IF(KFD2.GT.0) THEN
15840                 WID2=WID2*WIDS(KFC2,2)
15841               ELSE
15842                 WID2=WID2*WIDS(KFC2,3)
15843               ENDIF
15844               IF(KFD3.GT.0) THEN
15845                 WID2=WID2*WIDS(KFC3,2)
15846               ELSEIF(KFD3.LT.0) THEN
15847                 WID2=WID2*WIDS(KFC3,3)
15848               ENDIF
15849             ENDIF
15850
15851 C...Store effective widths according to case.
15852             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15853             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15854             WDTE(I,0)=WDTE(I,MDME(IDC,1))
15855             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15856           ENDIF
15857   120   CONTINUE
15858 C...Return.
15859         MINT(61)=0
15860         MINT(62)=0
15861         MINT(63)=0
15862         RETURN
15863       ENDIF
15864
15865 C...Here begins detailed dynamical calculation of resonance widths.
15866 C...Shared treatment of Higgs states.
15867       KFHIGG=25
15868       IHIGG=1
15869       IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
15870         KFHIGG=KFLA
15871         IHIGG=KFLA-33
15872       ENDIF
15873
15874 C...Common electroweak and strong constants.
15875       XW=PARU(102)
15876       XWV=XW
15877       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
15878       XW1=1D0-XW
15879       AEM=PYALEM(SH)
15880       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
15881       AS=PYALPS(SH)
15882       RADC=1D0+AS/PARU(1)
15883
15884       IF(KFLA.EQ.6) THEN
15885 C...t quark.
15886         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15887         RADCT=1D0-2.5D0*AS/PARU(1)
15888         DO 140 I=1,MDCY(KC,3)
15889           IDC=I+MDCY(KC,2)-1
15890           IF(MDME(IDC,1).LT.0) GOTO 140
15891           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15892           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15893           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
15894           WID2=1D0
15895           IF(I.GE.4.AND.I.LE.7) THEN
15896 C...t -> W + q; including approximate QCD correction factor.
15897             WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
15898      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15899      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
15900             IF(KFLR.GT.0) THEN
15901               WID2=WIDS(24,2)
15902               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
15903             ELSE
15904               WID2=WIDS(24,3)
15905               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
15906             ENDIF
15907           ELSEIF(I.EQ.9) THEN
15908 C...t -> H + b.
15909             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15910      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
15911             WID2=WIDS(37,2)
15912             IF(KFLR.LT.0) WID2=WIDS(37,3)
15913 CMRENNA++
15914           ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
15915 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
15916             BETA=ATAN(RMSS(5))
15917             SINB=SIN(BETA)
15918             TANW=SQRT(PARU(102)/(1D0-PARU(102)))
15919             ET=KCHG(6,1)/3D0
15920             T3L=SIGN(0.5D0,ET)
15921             KFC1=PYCOMP(KFDP(IDC,1))
15922             KFC2=PYCOMP(KFDP(IDC,2))
15923             PMNCHI=PMAS(KFC1,1)
15924             PMSTOP=PMAS(KFC2,1)
15925             IF(SHR.GT.PMNCHI+PMSTOP) THEN
15926               IZ=I-9
15927               DO 130 IK=1,4
15928                 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
15929   130         CONTINUE
15930               AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
15931               AR=-ET*ZMIXC(IZ,1)*TANW
15932               BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
15933               BR=AL
15934               FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
15935               FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
15936               PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15937      &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15938               WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
15939      &        ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
15940      &        SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
15941               IF(KFLR.GT.0) THEN
15942                 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15943               ELSE
15944                 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15945               ENDIF
15946             ENDIF
15947           ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
15948 C...t -> ~g + ~t
15949             KFC1=PYCOMP(KFDP(IDC,1))
15950             KFC2=PYCOMP(KFDP(IDC,2))
15951             PMNCHI=PMAS(KFC1,1)
15952             PMSTOP=PMAS(KFC2,1)
15953             IF(SHR.GT.PMNCHI+PMSTOP) THEN
15954               RL=SFMIX(6,1)
15955               RR=-SFMIX(6,2)
15956               PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15957      &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15958               WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
15959      &        (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
15960               IF(KFLR.GT.0) THEN
15961                 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15962               ELSE
15963                 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15964               ENDIF
15965             ENDIF
15966           ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
15967 C...t -> ~gravitino + ~t
15968             XMP2=RMSS(29)**2
15969             KFC1=PYCOMP(KFDP(IDC,1))
15970             XMGR2=PMAS(KFC1,1)**2
15971             WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
15972             KFC2=PYCOMP(KFDP(IDC,2))
15973             WID2=WIDS(KFC2,2)
15974             IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
15975 CMRENNA--
15976           ENDIF
15977           WDTP(I)=FUDGE*WDTP(I)
15978           WDTP(0)=WDTP(0)+WDTP(I)
15979           IF(MDME(IDC,1).GT.0) THEN
15980             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15981             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15982             WDTE(I,0)=WDTE(I,MDME(IDC,1))
15983             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15984           ENDIF
15985   140   CONTINUE
15986
15987       ELSEIF(KFLA.EQ.7) THEN
15988 C...b' quark.
15989         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15990         DO 150 I=1,MDCY(KC,3)
15991           IDC=I+MDCY(KC,2)-1
15992           IF(MDME(IDC,1).LT.0) GOTO 150
15993           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15994           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15995           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
15996           WID2=1D0
15997           IF(I.GE.4.AND.I.LE.7) THEN
15998 C...b' -> W + q.
15999             WDTP(I)=FAC*VCKM(I-3,4)*
16000      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16001      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16002             IF(KFLR.GT.0) THEN
16003               WID2=WIDS(24,3)
16004               IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16005               IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16006             ELSE
16007               WID2=WIDS(24,2)
16008               IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16009               IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16010             ENDIF
16011             WID2=WIDS(24,3)
16012             IF(KFLR.LT.0) WID2=WIDS(24,2)
16013           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16014 C...b' -> H + q.
16015             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16016      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16017             IF(KFLR.GT.0) THEN
16018               WID2=WIDS(37,3)
16019               IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16020             ELSE
16021               WID2=WIDS(37,2)
16022               IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16023             ENDIF
16024           ENDIF
16025           WDTP(I)=FUDGE*WDTP(I)
16026           WDTP(0)=WDTP(0)+WDTP(I)
16027           IF(MDME(IDC,1).GT.0) THEN
16028             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16029             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16030             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16031             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16032           ENDIF
16033   150   CONTINUE
16034
16035       ELSEIF(KFLA.EQ.8) THEN
16036 C...t' quark.
16037         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16038         DO 160 I=1,MDCY(KC,3)
16039           IDC=I+MDCY(KC,2)-1
16040           IF(MDME(IDC,1).LT.0) GOTO 160
16041           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16042           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16043           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16044           WID2=1D0
16045           IF(I.GE.4.AND.I.LE.7) THEN
16046 C...t' -> W + q.
16047             WDTP(I)=FAC*VCKM(4,I-3)*
16048      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16049      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16050             IF(KFLR.GT.0) THEN
16051               WID2=WIDS(24,2)
16052               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16053             ELSE
16054               WID2=WIDS(24,3)
16055               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16056             ENDIF
16057           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16058 C...t' -> H + q.
16059             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16060      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16061             IF(KFLR.GT.0) THEN
16062               WID2=WIDS(37,2)
16063               IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16064             ELSE
16065               WID2=WIDS(37,3)
16066               IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16067             ENDIF
16068           ENDIF
16069           WDTP(I)=FUDGE*WDTP(I)
16070           WDTP(0)=WDTP(0)+WDTP(I)
16071           IF(MDME(IDC,1).GT.0) THEN
16072             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16073             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16074             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16075             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16076           ENDIF
16077   160   CONTINUE
16078
16079       ELSEIF(KFLA.EQ.17) THEN
16080 C...tau' lepton.
16081         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16082         DO 170 I=1,MDCY(KC,3)
16083           IDC=I+MDCY(KC,2)-1
16084           IF(MDME(IDC,1).LT.0) GOTO 170
16085           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16086           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16087           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16088           WID2=1D0
16089           IF(I.EQ.3) THEN
16090 C...tau' -> W + nu'_tau.
16091             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16092      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16093             IF(KFLR.GT.0) THEN
16094               WID2=WIDS(24,3)
16095               WID2=WID2*WIDS(18,2)
16096             ELSE
16097               WID2=WIDS(24,2)
16098               WID2=WID2*WIDS(18,3)
16099             ENDIF
16100           ELSEIF(I.EQ.5) THEN
16101 C...tau' -> H + nu'_tau.
16102             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16103      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16104             IF(KFLR.GT.0) THEN
16105               WID2=WIDS(37,3)
16106               WID2=WID2*WIDS(18,2)
16107             ELSE
16108               WID2=WIDS(37,2)
16109               WID2=WID2*WIDS(18,3)
16110             ENDIF
16111           ENDIF
16112           WDTP(I)=FUDGE*WDTP(I)
16113           WDTP(0)=WDTP(0)+WDTP(I)
16114           IF(MDME(IDC,1).GT.0) THEN
16115             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16116             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16117             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16118             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16119           ENDIF
16120   170   CONTINUE
16121
16122       ELSEIF(KFLA.EQ.18) THEN
16123 C...nu'_tau neutrino.
16124         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16125         DO 180 I=1,MDCY(KC,3)
16126           IDC=I+MDCY(KC,2)-1
16127           IF(MDME(IDC,1).LT.0) GOTO 180
16128           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16129           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16130           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16131           WID2=1D0
16132           IF(I.EQ.2) THEN
16133 C...nu'_tau -> W + tau'.
16134             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16135      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16136             IF(KFLR.GT.0) THEN
16137               WID2=WIDS(24,2)
16138               WID2=WID2*WIDS(17,2)
16139             ELSE
16140               WID2=WIDS(24,3)
16141               WID2=WID2*WIDS(17,3)
16142             ENDIF
16143           ELSEIF(I.EQ.3) THEN
16144 C...nu'_tau -> H + tau'.
16145             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16146      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16147             IF(KFLR.GT.0) THEN
16148               WID2=WIDS(37,2)
16149               WID2=WID2*WIDS(17,2)
16150             ELSE
16151               WID2=WIDS(37,3)
16152               WID2=WID2*WIDS(17,3)
16153             ENDIF
16154           ENDIF
16155           WDTP(I)=FUDGE*WDTP(I)
16156           WDTP(0)=WDTP(0)+WDTP(I)
16157           IF(MDME(IDC,1).GT.0) THEN
16158             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16159             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16160             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16161             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16162           ENDIF
16163   180   CONTINUE
16164
16165       ELSEIF(KFLA.EQ.21) THEN
16166 C...QCD:
16167 C***Note that widths are not given in dimensional quantities here.
16168         DO 190 I=1,MDCY(KC,3)
16169           IDC=I+MDCY(KC,2)-1
16170           IF(MDME(IDC,1).LT.0) GOTO 190
16171           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16172           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16173           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16174           WID2=1D0
16175           IF(I.LE.8) THEN
16176 C...QCD -> q + qbar
16177             WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16178             IF(I.EQ.6) WID2=WIDS(6,1)
16179             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16180           ENDIF
16181           WDTP(I)=FUDGE*WDTP(I)
16182           WDTP(0)=WDTP(0)+WDTP(I)
16183           IF(MDME(IDC,1).GT.0) THEN
16184             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16185             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16186             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16187             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16188           ENDIF
16189   190   CONTINUE
16190
16191       ELSEIF(KFLA.EQ.22) THEN
16192 C...QED photon.
16193 C***Note that widths are not given in dimensional quantities here.
16194         DO 200 I=1,MDCY(KC,3)
16195           IDC=I+MDCY(KC,2)-1
16196           IF(MDME(IDC,1).LT.0) GOTO 200
16197           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16198           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16199           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16200           WID2=1D0
16201           IF(I.LE.8) THEN
16202 C...QED -> q + qbar.
16203             EF=KCHG(I,1)/3D0
16204             FCOF=3D0*RADC
16205             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16206             WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16207             IF(I.EQ.6) WID2=WIDS(6,1)
16208             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16209           ELSEIF(I.LE.12) THEN
16210 C...QED -> l+ + l-.
16211             EF=KCHG(9+2*(I-8),1)/3D0
16212             WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16213             IF(I.EQ.12) WID2=WIDS(17,1)
16214           ENDIF
16215           WDTP(I)=FUDGE*WDTP(I)
16216           WDTP(0)=WDTP(0)+WDTP(I)
16217           IF(MDME(IDC,1).GT.0) THEN
16218             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16219             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16220             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16221             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16222           ENDIF
16223   200   CONTINUE
16224
16225       ELSEIF(KFLA.EQ.23) THEN
16226 C...Z0:
16227         ICASE=1
16228         XWC=1D0/(16D0*XW*XW1)
16229         FAC=(AEM*XWC/3D0)*SHR
16230   210   CONTINUE
16231         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16232           VINT(111)=0D0
16233           VINT(112)=0D0
16234           VINT(114)=0D0
16235         ENDIF
16236         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16237           KFI=IABS(MINT(15))
16238           IF(KFI.GT.20) KFI=IABS(MINT(16))
16239           EI=KCHG(KFI,1)/3D0
16240           AI=SIGN(1D0,EI)
16241           VI=AI-4D0*EI*XWV
16242           SQMZ=PMAS(23,1)**2
16243           HZ=SHR*WDTP(0)
16244           IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16245           IF(MSTP(43).EQ.3) VINT(112)=
16246      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16247           IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16248      &    XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16249         ENDIF
16250         DO 220 I=1,MDCY(KC,3)
16251           IDC=I+MDCY(KC,2)-1
16252           IF(MDME(IDC,1).LT.0) GOTO 220
16253           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16254           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16255           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16256           WID2=1D0
16257           IF(I.LE.8) THEN
16258 C...Z0 -> q + qbar
16259             EF=KCHG(I,1)/3D0
16260             AF=SIGN(1D0,EF+0.1D0)
16261             VF=AF-4D0*EF*XWV
16262             FCOF=3D0*RADC
16263             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16264             IF(I.EQ.6) WID2=WIDS(6,1)
16265             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16266           ELSEIF(I.LE.16) THEN
16267 C...Z0 -> l+ + l-, nu + nubar
16268             EF=KCHG(I+2,1)/3D0
16269             AF=SIGN(1D0,EF+0.1D0)
16270             VF=AF-4D0*EF*XWV
16271             FCOF=1D0
16272             IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16273           ENDIF
16274           BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16275           IF(ICASE.EQ.1) THEN
16276             WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16277      &      BE34
16278           ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16279             WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16280      &      EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16281      &      (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16282           ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16283             FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16284             FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16285             FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16286           ENDIF
16287           IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16288           IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16289           IF(MDME(IDC,1).GT.0) THEN
16290             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16291      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16292               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16293               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16294      &        WDTE(I,MDME(IDC,1))
16295               WDTE(I,0)=WDTE(I,MDME(IDC,1))
16296               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16297             ENDIF
16298             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16299               IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16300      &        VINT(111)+FGGF*WID2
16301               IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16302               IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16303      &        VINT(114)+FZZF*WID2
16304             ENDIF
16305           ENDIF
16306   220   CONTINUE
16307         IF(MINT(61).GE.1) ICASE=3-ICASE
16308         IF(ICASE.EQ.2) GOTO 210
16309
16310       ELSEIF(KFLA.EQ.24) THEN
16311 C...W+/-:
16312         FAC=(AEM/(24D0*XW))*SHR
16313         DO 230 I=1,MDCY(KC,3)
16314           IDC=I+MDCY(KC,2)-1
16315           IF(MDME(IDC,1).LT.0) GOTO 230
16316           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16317           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16318           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16319           WID2=1D0
16320           IF(I.LE.16) THEN
16321 C...W+/- -> q + qbar'
16322             FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16323             IF(KFLR.GT.0) THEN
16324               IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16325               IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16326               IF(I.GE.13) WID2=WID2*WIDS(7,3)
16327             ELSE
16328               IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16329               IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16330               IF(I.GE.13) WID2=WID2*WIDS(7,2)
16331             ENDIF
16332           ELSEIF(I.LE.20) THEN
16333 C...W+/- -> l+/- + nu
16334             FCOF=1D0
16335             IF(KFLR.GT.0) THEN
16336               IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16337             ELSE
16338               IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16339             ENDIF
16340           ENDIF
16341           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16342      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16343           WDTP(I)=FUDGE*WDTP(I)
16344           WDTP(0)=WDTP(0)+WDTP(I)
16345           IF(MDME(IDC,1).GT.0) THEN
16346             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16347             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16348             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16349             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16350           ENDIF
16351   230   CONTINUE
16352
16353       ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16354 C...h0 (or H0, or A0):
16355         IF(MSTP(49).EQ.0) THEN
16356           SHFS=SH
16357         ELSE
16358           SHFS=PMAS(KFHIGG,1)**2
16359         ENDIF
16360         FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16361         DO 270 I=1,MDCY(KFHIGG,3)
16362           IDC=I+MDCY(KFHIGG,2)-1
16363           IF(MDME(IDC,1).LT.0) GOTO 270
16364           KFC1=PYCOMP(KFDP(IDC,1))
16365           KFC2=PYCOMP(KFDP(IDC,2))
16366           RM1=PMAS(KFC1,1)**2/SH
16367           RM2=PMAS(KFC2,1)**2/SH
16368           IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16369      &    GOTO 270
16370           WID2=1D0
16371
16372           IF(I.LE.8) THEN
16373 C...h0 -> q + qbar
16374             WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16375      &      SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16376 C...A0 behaves like beta, ho and H0 like beta**3.
16377             IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16378             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16379               IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16380               IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16381               IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16382                 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16383                 IF(IHIGG.NE.3) THEN
16384                   WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16385      &            PARU(151+10*IHIGG))**2
16386                 ENDIF
16387               ENDIF
16388             ENDIF
16389             IF(I.EQ.6) WID2=WIDS(6,1)
16390             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16391           ELSEIF(I.LE.12) THEN
16392 C...h0 -> l+ + l-
16393             WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16394 C...A0 behaves like beta, ho and H0 like beta**3.
16395             IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16396             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16397      &      PARU(153+10*IHIGG)**2
16398             IF(I.EQ.12) WID2=WIDS(17,1)
16399
16400           ELSEIF(I.EQ.13) THEN
16401 C...h0 -> g + g; quark loop contribution only
16402             ETARE=0D0
16403             ETAIM=0D0
16404             DO 240 J=1,2*MSTP(1)
16405               EPS=(2D0*PMAS(J,1))**2/SH
16406 C...Loop integral; function of eps=4m^2/shat; different for A0.
16407               IF(EPS.LE.1D0) THEN
16408                 IF(EPS.GT.1D-4) THEN
16409                   ROOT=SQRT(1D0-EPS)
16410                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16411                 ELSE
16412                   RLN=LOG(4D0/EPS-2D0)
16413                 ENDIF
16414                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16415                 PHIIM=0.5D0*PARU(1)*RLN
16416               ELSE
16417                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16418                 PHIIM=0D0
16419               ENDIF
16420               IF(IHIGG.LE.2) THEN
16421                 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16422                 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16423               ELSE
16424                 ETAREJ=-0.5D0*EPS*PHIRE
16425                 ETAIMJ=-0.5D0*EPS*PHIIM
16426               ENDIF
16427 C...Couplings (=1 for standard model Higgs).
16428               IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16429                 IF(MOD(J,2).EQ.1) THEN
16430                   ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16431                   ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16432                 ELSE
16433                   ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16434                   ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16435                 ENDIF
16436               ENDIF
16437               ETARE=ETARE+ETAREJ
16438               ETAIM=ETAIM+ETAIMJ
16439   240       CONTINUE
16440             ETA2=ETARE**2+ETAIM**2
16441             WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16442
16443           ELSEIF(I.EQ.14) THEN
16444 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16445             ETARE=0D0
16446             ETAIM=0D0
16447             JMAX=3*MSTP(1)+1
16448             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16449             DO 250 J=1,JMAX
16450               IF(J.LE.2*MSTP(1)) THEN
16451                 EJ=KCHG(J,1)/3D0
16452                 EPS=(2D0*PMAS(J,1))**2/SH
16453               ELSEIF(J.LE.3*MSTP(1)) THEN
16454                 JL=2*(J-2*MSTP(1))-1
16455                 EJ=KCHG(10+JL,1)/3D0
16456                 EPS=(2D0*PMAS(10+JL,1))**2/SH
16457               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16458                 EPS=(2D0*PMAS(24,1))**2/SH
16459               ELSE
16460                 EPS=(2D0*PMAS(37,1))**2/SH
16461               ENDIF
16462 C...Loop integral; function of eps=4m^2/shat.
16463               IF(EPS.LE.1D0) THEN
16464                 IF(EPS.GT.1D-4) THEN
16465                   ROOT=SQRT(1D0-EPS)
16466                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16467                 ELSE
16468                   RLN=LOG(4D0/EPS-2D0)
16469                 ENDIF
16470                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16471                 PHIIM=0.5D0*PARU(1)*RLN
16472               ELSE
16473                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16474                 PHIIM=0D0
16475               ENDIF
16476               IF(J.LE.3*MSTP(1)) THEN
16477 C...Fermion loops: loop integral different for A0; charges.
16478                 IF(IHIGG.LE.2) THEN
16479                   PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16480                   PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16481                 ELSE
16482                   PHIPRE=-0.5D0*EPS*PHIRE
16483                   PHIPIM=-0.5D0*EPS*PHIIM
16484                 ENDIF
16485                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16486                   EJC=3D0*EJ**2
16487                   EJH=PARU(151+10*IHIGG)
16488                 ELSEIF(J.LE.2*MSTP(1)) THEN
16489                   EJC=3D0*EJ**2
16490                   EJH=PARU(152+10*IHIGG)
16491                 ELSE
16492                   EJC=EJ**2
16493                   EJH=PARU(153+10*IHIGG)
16494                 ENDIF
16495                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16496                 ETAREJ=EJC*EJH*PHIPRE
16497                 ETAIMJ=EJC*EJH*PHIPIM
16498               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16499 C...W loops: loop integral and charges.
16500                 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16501                 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16502                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16503                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16504                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16505                 ENDIF
16506               ELSE
16507 C...Charged H loops: loop integral and charges.
16508                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16509      &          PARU(158+10*IHIGG+2*(IHIGG/3))
16510                 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16511                 ETAIMJ=-EPS**2*PHIIM*FACHHH
16512               ENDIF
16513               ETARE=ETARE+ETAREJ
16514               ETAIM=ETAIM+ETAIMJ
16515   250       CONTINUE
16516             ETA2=ETARE**2+ETAIM**2
16517             WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16518
16519           ELSEIF(I.EQ.15) THEN
16520 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16521             ETARE=0D0
16522             ETAIM=0D0
16523             JMAX=3*MSTP(1)+1
16524             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16525             DO 260 J=1,JMAX
16526               IF(J.LE.2*MSTP(1)) THEN
16527                 EJ=KCHG(J,1)/3D0
16528                 AJ=SIGN(1D0,EJ+0.1D0)
16529                 VJ=AJ-4D0*EJ*XWV
16530                 EPS=(2D0*PMAS(J,1))**2/SH
16531                 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16532               ELSEIF(J.LE.3*MSTP(1)) THEN
16533                 JL=2*(J-2*MSTP(1))-1
16534                 EJ=KCHG(10+JL,1)/3D0
16535                 AJ=SIGN(1D0,EJ+0.1D0)
16536                 VJ=AJ-4D0*EJ*XWV
16537                 EPS=(2D0*PMAS(10+JL,1))**2/SH
16538                 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16539               ELSE
16540                 EPS=(2D0*PMAS(24,1))**2/SH
16541                 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16542               ENDIF
16543 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16544               IF(EPS.LE.1D0) THEN
16545                 ROOT=SQRT(1D0-EPS)
16546                 IF(EPS.GT.1D-4) THEN
16547                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16548                 ELSE
16549                   RLN=LOG(4D0/EPS-2D0)
16550                 ENDIF
16551                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16552                 PHIIM=0.5D0*PARU(1)*RLN
16553                 PSIRE=0.5D0*ROOT*RLN
16554                 PSIIM=-0.5D0*ROOT*PARU(1)
16555               ELSE
16556                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16557                 PHIIM=0D0
16558                 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16559                 PSIIM=0D0
16560               ENDIF
16561               IF(EPSP.LE.1D0) THEN
16562                 ROOT=SQRT(1D0-EPSP)
16563                 IF(EPSP.GT.1D-4) THEN
16564                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16565                 ELSE
16566                   RLN=LOG(4D0/EPSP-2D0)
16567                 ENDIF
16568                 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16569                 PHIIMP=0.5D0*PARU(1)*RLN
16570                 PSIREP=0.5D0*ROOT*RLN
16571                 PSIIMP=-0.5D0*ROOT*PARU(1)
16572               ELSE
16573                 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16574                 PHIIMP=0D0
16575                 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16576                 PSIIMP=0D0
16577               ENDIF
16578               FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16579      &        (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16580               FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16581      &        (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16582               F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16583               F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16584               IF(J.LE.3*MSTP(1)) THEN
16585 C...Fermion loops: loop integral different for A0; charges.
16586                 IF(IHIGG.EQ.3) FXYRE=0D0
16587                 IF(IHIGG.EQ.3) FXYIM=0D0
16588                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16589                   EJC=-3D0*EJ*VJ
16590                   EJH=PARU(151+10*IHIGG)
16591                 ELSEIF(J.LE.2*MSTP(1)) THEN
16592                   EJC=-3D0*EJ*VJ
16593                   EJH=PARU(152+10*IHIGG)
16594                 ELSE
16595                   EJC=-EJ*VJ
16596                   EJH=PARU(153+10*IHIGG)
16597                 ENDIF
16598                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16599                 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16600                 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16601               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16602 C...W loops: loop integral and charges.
16603                 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16604                 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16605                 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16606                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16607                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16608                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16609                 ENDIF
16610               ELSE
16611 C...Charged H loops: loop integral and charges.
16612                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16613      &          PARU(158+10*IHIGG+2*(IHIGG/3))
16614                 ETAREJ=FACHHH*FXYRE
16615                 ETAIMJ=FACHHH*FXYIM
16616               ENDIF
16617               ETARE=ETARE+ETAREJ
16618               ETAIM=ETAIM+ETAIMJ
16619   260       CONTINUE
16620             ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
16621             WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
16622             WID2=WIDS(23,2)
16623
16624           ELSEIF(I.LE.17) THEN
16625 C...h0 -> Z0 + Z0, W+ + W-
16626             PM1=PMAS(IABS(KFDP(IDC,1)),1)
16627             PG1=PMAS(IABS(KFDP(IDC,1)),2)
16628             IF(MINT(62).GE.1) THEN
16629               IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
16630      &        CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
16631      &        MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
16632                 MOFSV(IHIGG,I-15)=0
16633                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16634      &          1D0-4D0*RM1))
16635                 WID2=1D0
16636               ELSE
16637                 MOFSV(IHIGG,I-15)=1
16638                 RMAS=SQRT(MAX(0D0,SH))
16639                 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
16640      &          WID2)
16641                 WIDWSV(IHIGG,I-15)=WIDW
16642                 WID2SV(IHIGG,I-15)=WID2
16643               ENDIF
16644             ELSE
16645               IF(MOFSV(IHIGG,I-15).EQ.0) THEN
16646                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16647      &          1D0-4D0*RM1))
16648                 WID2=1D0
16649               ELSE
16650                 WIDW=WIDWSV(IHIGG,I-15)
16651                 WID2=WID2SV(IHIGG,I-15)
16652               ENDIF
16653             ENDIF
16654             WDTP(I)=FAC*WIDW/(2D0*(18-I))
16655             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16656      &      PARU(138+I+10*IHIGG)**2
16657             WID2=WID2*WIDS(7+I,1)
16658
16659           ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
16660 C...H0 -> Z0 + h0, A0-> Z0 + h0
16661             WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16662      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16663             IF(IHIGG.EQ.2) THEN
16664              WDTP(I)=WDTP(I)*PARU(179)**2
16665             ELSEIF(IHIGG.EQ.3) THEN
16666              WDTP(I)=WDTP(I)*PARU(186)**2
16667             ENDIF
16668             WID2=WIDS(23,2)*WIDS(25,2)
16669
16670           ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
16671 C...H0 -> h0 + h0, A0-> h0 + h0
16672             WDTP(I)=FAC*0.25D0*
16673      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16674             IF(IHIGG.EQ.2) THEN
16675              WDTP(I)=WDTP(I)*PARU(176)**2
16676             ELSEIF(IHIGG.EQ.3) THEN
16677              WDTP(I)=WDTP(I)*PARU(169)**2
16678             ENDIF
16679             WID2=WIDS(25,1)
16680           ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
16681 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
16682             WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16683      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16684      &      *PARU(195+IHIGG)**2
16685             IF(I.EQ.20) THEN
16686               WID2=WIDS(24,2)*WIDS(37,3)
16687             ELSEIF(I.EQ.21) THEN
16688               WID2=WIDS(24,3)*WIDS(37,2)
16689             ENDIF
16690
16691           ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
16692 C...H0 -> Z0 + A0.
16693             WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
16694      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
16695             WID2=WIDS(36,2)*WIDS(23,2)
16696
16697           ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
16698 C...H0 -> h0 + A0.
16699             WDTP(I)=FAC*0.5D0*PARU(180)**2*
16700      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16701             WID2=WIDS(25,2)*WIDS(36,2)
16702
16703           ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
16704 C...H0 -> A0 + A0
16705             WDTP(I)=FAC*0.25D0*PARU(177)**2*
16706      &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16707             WID2=WIDS(36,1)
16708
16709 CMRENNA++
16710           ELSE
16711 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
16712             RM10=RM1*SH/PMR**2
16713             RM20=RM2*SH/PMR**2
16714             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
16715             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
16716             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
16717               WFAC=0D0
16718             ELSE
16719               WFAC=WFAC/WFAC0
16720             ENDIF
16721             WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
16722 CMRENNA--
16723             IF(KFC2.EQ.KFC1) THEN
16724               WID2=WIDS(KFC1,1)
16725             ELSE
16726               KSGN1=2
16727               IF(KFDP(IDC,1).LT.0) KSGN1=3
16728               KSGN2=2
16729               IF(KFDP(IDC,2).LT.0) KSGN2=3
16730               WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
16731             ENDIF
16732           ENDIF
16733           WDTP(I)=FUDGE*WDTP(I)
16734           WDTP(0)=WDTP(0)+WDTP(I)
16735           IF(MDME(IDC,1).GT.0) THEN
16736             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16737             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16738             WDTE(I,0)=WDTE(I,MDME(IDC,1))
16739             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16740           ENDIF
16741   270   CONTINUE
16742
16743       ELSEIF(KFLA.EQ.32) THEN
16744 C...Z'0:
16745         ICASE=1
16746         XWC=1D0/(16D0*XW*XW1)
16747         FAC=(AEM*XWC/3D0)*SHR
16748         VINT(117)=0D0
16749   280   CONTINUE
16750         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16751           VINT(111)=0D0
16752           VINT(112)=0D0
16753           VINT(113)=0D0
16754           VINT(114)=0D0
16755           VINT(115)=0D0
16756           VINT(116)=0D0
16757         ENDIF
16758         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16759           KFAI=IABS(MINT(15))
16760           EI=KCHG(KFAI,1)/3D0
16761           AI=SIGN(1D0,EI+0.1D0)
16762           VI=AI-4D0*EI*XWV
16763           KFAIC=1
16764           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
16765           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
16766           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
16767           IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
16768             VPI=PARU(119+2*KFAIC)
16769             API=PARU(120+2*KFAIC)
16770           ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
16771             VPI=PARJ(178+2*KFAIC)
16772             API=PARJ(179+2*KFAIC)
16773           ELSE
16774             VPI=PARJ(186+2*KFAIC)
16775             API=PARJ(187+2*KFAIC)
16776           ENDIF
16777           SQMZ=PMAS(23,1)**2
16778           HZ=SHR*VINT(117)
16779           SQMZP=PMAS(32,1)**2
16780           HZP=SHR*WDTP(0)
16781           IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16782      &    MSTP(44).EQ.7) VINT(111)=1D0
16783           IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
16784      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16785           IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
16786      &    2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
16787           IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16788      &    MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16789           IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
16790      &    2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
16791      &    (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
16792           IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16793      &    MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
16794         ENDIF
16795         DO 290 I=1,MDCY(KC,3)
16796           IDC=I+MDCY(KC,2)-1
16797           IF(MDME(IDC,1).LT.0) GOTO 290
16798           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16799           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16800           IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
16801           WID2=1D0
16802           IF(I.LE.16) THEN
16803             IF(I.LE.8) THEN
16804 C...Z'0 -> q + qbar
16805               EF=KCHG(I,1)/3D0
16806               AF=SIGN(1D0,EF+0.1D0)
16807               VF=AF-4D0*EF*XWV
16808               IF(I.LE.2) THEN
16809                 VPF=PARU(123-2*MOD(I,2))
16810                 APF=PARU(124-2*MOD(I,2))
16811               ELSEIF(I.LE.4) THEN
16812                 VPF=PARJ(182-2*MOD(I,2))
16813                 APF=PARJ(183-2*MOD(I,2))
16814               ELSE
16815                 VPF=PARJ(190-2*MOD(I,2))
16816                 APF=PARJ(191-2*MOD(I,2))
16817               ENDIF
16818               FCOF=3D0*RADC
16819               IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
16820      &        PYHFTH(SH,SH*RM1,1D0)
16821               IF(I.EQ.6) WID2=WIDS(6,1)
16822               IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16823             ELSEIF(I.LE.16) THEN
16824 C...Z'0 -> l+ + l-, nu + nubar
16825               EF=KCHG(I+2,1)/3D0
16826               AF=SIGN(1D0,EF+0.1D0)
16827               VF=AF-4D0*EF*XWV
16828               IF(I.LE.10) THEN
16829                 VPF=PARU(127-2*MOD(I,2))
16830                 APF=PARU(128-2*MOD(I,2))
16831               ELSEIF(I.LE.12) THEN
16832                 VPF=PARJ(186-2*MOD(I,2))
16833                 APF=PARJ(187-2*MOD(I,2))
16834               ELSE
16835                 VPF=PARJ(194-2*MOD(I,2))
16836                 APF=PARJ(195-2*MOD(I,2))
16837               ENDIF
16838               FCOF=1D0
16839               IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16840             ENDIF
16841             BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16842             IF(ICASE.EQ.1) THEN
16843               WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16844               WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
16845      &        APF**2*(1D0-4D0*RM1))*BE34
16846             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16847               WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16848      &        EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
16849      &        VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
16850      &        VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
16851      &        AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
16852      &        VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
16853             ELSEIF(MINT(61).EQ.2) THEN
16854               FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16855               FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16856               FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
16857               FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16858               FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
16859      &        BE34
16860               FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
16861      &        BE34
16862             ENDIF
16863           ELSEIF(I.EQ.17) THEN
16864 C...Z'0 -> W+ + W-
16865             WDTPZP=PARU(129)**2*XW1**2*
16866      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16867      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
16868             IF(ICASE.EQ.1) THEN
16869               WDTPZ=0D0
16870               WDTP(I)=FAC*WDTPZP
16871             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16872               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16873             ELSEIF(MINT(61).EQ.2) THEN
16874               FGGF=0D0
16875               FGZF=0D0
16876               FGZPF=0D0
16877               FZZF=0D0
16878               FZZPF=0D0
16879               FZPZPF=WDTPZP
16880             ENDIF
16881             WID2=WIDS(24,1)
16882           ELSEIF(I.EQ.18) THEN
16883 C...Z'0 -> H+ + H-
16884             CZC=2D0*(1D0-2D0*XW)
16885             BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16886             IF(ICASE.EQ.1) THEN
16887               WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
16888               WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
16889             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16890               WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
16891      &        VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
16892      &        (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
16893      &        (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
16894      &        (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
16895             ELSEIF(MINT(61).EQ.2) THEN
16896               FGGF=0.25D0*BE34C
16897               FGZF=0.25D0*PARU(142)*CZC*BE34C
16898               FGZPF=0.25D0*PARU(143)*CZC*BE34C
16899               FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
16900               FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
16901               FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
16902             ENDIF
16903             WID2=WIDS(37,1)
16904           ELSEIF(I.EQ.19) THEN
16905 C...Z'0 -> Z0 + gamma.
16906           ELSEIF(I.EQ.20) THEN
16907 C...Z'0 -> Z0 + h0
16908             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16909             WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
16910      &      (3D0*RM1+0.25D0*FLAM**2)*FLAM
16911             IF(ICASE.EQ.1) THEN
16912               WDTPZ=0D0
16913               WDTP(I)=FAC*WDTPZP
16914             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16915               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16916             ELSEIF(MINT(61).EQ.2) THEN
16917               FGGF=0D0
16918               FGZF=0D0
16919               FGZPF=0D0
16920               FZZF=0D0
16921               FZZPF=0D0
16922               FZPZPF=WDTPZP
16923             ENDIF
16924             WID2=WIDS(23,2)*WIDS(25,2)
16925           ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
16926 C...Z' -> h0 + A0 or H0 + A0.
16927             BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16928             IF(I.EQ.21) THEN
16929               CZAH=PARU(186)
16930               CZPAH=PARU(188)
16931             ELSE
16932               CZAH=PARU(187)
16933               CZPAH=PARU(189)
16934             ENDIF
16935             IF(ICASE.EQ.1) THEN
16936               WDTPZ=CZAH**2*BE34C
16937               WDTP(I)=FAC*CZPAH**2*BE34C
16938             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16939               WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
16940      &        (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
16941      &        VINT(116))*BE34C
16942             ELSEIF(MINT(61).EQ.2) THEN
16943               FGGF=0D0
16944               FGZF=0D0
16945               FGZPF=0D0
16946               FZZF=CZAH**2*BE34C
16947               FZZPF=CZAH*CZPAH*BE34C
16948               FZPZPF=CZPAH**2*BE34C
16949             ENDIF
16950             IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
16951             IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
16952           ENDIF
16953           IF(ICASE.EQ.1) THEN
16954             VINT(117)=VINT(117)+FAC*WDTPZ
16955             WDTP(I)=FUDGE*WDTP(I)
16956             WDTP(0)=WDTP(0)+WDTP(I)
16957           ENDIF
16958           IF(MDME(IDC,1).GT.0) THEN
16959             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16960      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16961               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16962               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16963      &        WDTE(I,MDME(IDC,1))
16964               WDTE(I,0)=WDTE(I,MDME(IDC,1))
16965               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16966             ENDIF
16967             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16968               IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16969      &        MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
16970               IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
16971      &        FGZF*WID2
16972               IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
16973      &        FGZPF*WID2
16974               IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16975      &        MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
16976               IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
16977      &        FZZPF*WID2
16978               IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16979      &        MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
16980             ENDIF
16981           ENDIF
16982   290   CONTINUE
16983         IF(MINT(61).GE.1) ICASE=3-ICASE
16984         IF(ICASE.EQ.2) GOTO 280
16985
16986       ELSEIF(KFLA.EQ.34) THEN
16987 C...W'+/-:
16988         FAC=(AEM/(24D0*XW))*SHR
16989         DO 300 I=1,MDCY(KC,3)
16990           IDC=I+MDCY(KC,2)-1
16991           IF(MDME(IDC,1).LT.0) GOTO 300
16992           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16993           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16994           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
16995           WID2=1D0
16996           IF(I.LE.20) THEN
16997             IF(I.LE.16) THEN
16998 C...W'+/- -> q + qbar'
16999               FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17000      &        VCKM((I-1)/4+1,MOD(I-1,4)+1)
17001               IF(KFLR.GT.0) THEN
17002                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17003                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17004                 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17005               ELSE
17006                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17007                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17008                 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17009               ENDIF
17010             ELSEIF(I.LE.20) THEN
17011 C...W'+/- -> l+/- + nu
17012               FCOF=PARU(133)**2+PARU(134)**2
17013               IF(KFLR.GT.0) THEN
17014                 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17015               ELSE
17016                 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17017               ENDIF
17018             ENDIF
17019             WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17020      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17021           ELSEIF(I.EQ.21) THEN
17022 C...W'+/- -> W+/- + Z0
17023             WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17024      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17025      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17026             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17027             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17028           ELSEIF(I.EQ.23) THEN
17029 C...W'+/- -> W+/- + h0
17030             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17031             WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17032             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17033             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17034           ENDIF
17035           WDTP(I)=FUDGE*WDTP(I)
17036           WDTP(0)=WDTP(0)+WDTP(I)
17037           IF(MDME(IDC,1).GT.0) THEN
17038             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17039             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17040             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17041             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17042           ENDIF
17043   300   CONTINUE
17044
17045       ELSEIF(KFLA.EQ.37) THEN
17046 C...H+/-:
17047         IF(MSTP(49).EQ.0) THEN
17048           SHFS=SH
17049         ELSE
17050           SHFS=PMAS(37,1)**2
17051         ENDIF
17052         FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17053         DO 310 I=1,MDCY(KC,3)
17054           IDC=I+MDCY(KC,2)-1
17055           IF(MDME(IDC,1).LT.0) GOTO 310
17056           KFC1=PYCOMP(KFDP(IDC,1))
17057           KFC2=PYCOMP(KFDP(IDC,2))
17058           RM1=PMAS(KFC1,1)**2/SH
17059           RM2=PMAS(KFC2,1)**2/SH
17060           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17061           WID2=1D0
17062           IF(I.LE.4) THEN
17063 C...H+/- -> q + qbar'
17064             RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17065             RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17066             WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17067      &      RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17068      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17069             IF(KFLR.GT.0) THEN
17070               IF(I.EQ.3) WID2=WIDS(6,2)
17071               IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17072             ELSE
17073               IF(I.EQ.3) WID2=WIDS(6,3)
17074               IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17075             ENDIF
17076           ELSEIF(I.LE.8) THEN
17077 C...H+/- -> l+/- + nu
17078             WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17079      &      (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17080      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17081             IF(KFLR.GT.0) THEN
17082               IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17083             ELSE
17084               IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17085             ENDIF
17086           ELSEIF(I.EQ.9) THEN
17087 C...H+/- -> W+/- + h0.
17088             WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17089      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17090             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17091             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17092
17093 CMRENNA++
17094           ELSE
17095 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17096             RM10=RM1*SH/PMR**2
17097             RM20=RM2*SH/PMR**2
17098             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17099             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17100             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17101               WFAC=0D0
17102             ELSE
17103               WFAC=WFAC/WFAC0
17104             ENDIF
17105             WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17106 CMRENNA--
17107             KSGN1=2
17108             IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17109             KSGN2=2
17110             IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17111             WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17112           ENDIF
17113           WDTP(I)=FUDGE*WDTP(I)
17114           WDTP(0)=WDTP(0)+WDTP(I)
17115           IF(MDME(IDC,1).GT.0) THEN
17116             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17117             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17118             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17119             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17120           ENDIF
17121   310   CONTINUE
17122
17123       ELSEIF(KFLA.EQ.41) THEN
17124 C...R:
17125         FAC=(AEM/(12D0*XW))*SHR
17126         DO 320 I=1,MDCY(KC,3)
17127           IDC=I+MDCY(KC,2)-1
17128           IF(MDME(IDC,1).LT.0) GOTO 320
17129           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17130           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17131           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17132           WID2=1D0
17133           IF(I.LE.6) THEN
17134 C...R -> q + qbar'
17135             FCOF=3D0*RADC
17136           ELSEIF(I.LE.9) THEN
17137 C...R -> l+ + l'-
17138             FCOF=1D0
17139           ENDIF
17140           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17141      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17142           IF(KFLR.GT.0) THEN
17143             IF(I.EQ.4) WID2=WIDS(6,3)
17144             IF(I.EQ.5) WID2=WIDS(7,3)
17145             IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17146             IF(I.EQ.9) WID2=WIDS(17,3)
17147           ELSE
17148             IF(I.EQ.4) WID2=WIDS(6,2)
17149             IF(I.EQ.5) WID2=WIDS(7,2)
17150             IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17151             IF(I.EQ.9) WID2=WIDS(17,2)
17152           ENDIF
17153           WDTP(I)=FUDGE*WDTP(I)
17154           WDTP(0)=WDTP(0)+WDTP(I)
17155           IF(MDME(IDC,1).GT.0) THEN
17156             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17157             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17158             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17159             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17160           ENDIF
17161   320   CONTINUE
17162
17163       ELSEIF(KFLA.EQ.42) THEN
17164 C...LQ (leptoquark).
17165         FAC=(AEM/4D0)*PARU(151)*SHR
17166         DO 330 I=1,MDCY(KC,3)
17167           IDC=I+MDCY(KC,2)-1
17168           IF(MDME(IDC,1).LT.0) GOTO 330
17169           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17170           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17171           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17172           WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17173           WID2=1D0
17174           ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17175           IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17176           IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17177           ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17178           IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17179           IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17180           WDTP(I)=FUDGE*WDTP(I)
17181           WDTP(0)=WDTP(0)+WDTP(I)
17182           IF(MDME(IDC,1).GT.0) THEN
17183             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17184             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17185             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17186             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17187           ENDIF
17188   330   CONTINUE
17189
17190       ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17191 C...Techni-pi0 and techni-pi0':
17192         FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17193         DO 340 I=1,MDCY(KC,3)
17194           IDC=I+MDCY(KC,2)-1
17195           IF(MDME(IDC,1).LT.0) GOTO 340
17196           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17197           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17198           RM1=PM1**2/SH
17199           RM2=PM2**2/SH
17200           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17201           WID2=1D0
17202 C...pi_tc -> g + g
17203           IF(I.EQ.8) THEN
17204             FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
17205      &      /(8D0*PARU(1))*SH*SHR
17206             IF(KFLA.EQ.KTECHN+111) THEN
17207               FACP=FACP*PARP(149)
17208             ELSE
17209               FACP=FACP*PARP(150)
17210             ENDIF
17211             WDTP(I)=FACP
17212           ELSE
17213 C...pi_tc -> f + fbar.
17214             FCOF=1D0
17215             IKA=IABS(KFDP(IDC,1))
17216             IF(IKA.LT.10) FCOF=3D0*RADC
17217             HM1=PM1
17218             HM2=PM2
17219             IF(IKA.GE.4.AND.IKA.LE.6) THEN
17220                FCOF=FCOF*PARP(141+IKA)**2
17221                HM1=PYMRUN(KFDP(IDC,1),SH)
17222                HM2=PYMRUN(KFDP(IDC,2),SH)
17223             ELSEIF(IKA.EQ.15) THEN
17224                FCOF=FCOF*PARP(148)**2
17225             ENDIF
17226             WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17227      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17228           ENDIF
17229           WDTP(I)=FUDGE*WDTP(I)
17230           WDTP(0)=WDTP(0)+WDTP(I)
17231           IF(MDME(IDC,1).GT.0) THEN
17232             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17233             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17234             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17235             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17236           ENDIF
17237   340   CONTINUE
17238
17239       ELSEIF(KFLA.EQ.KTECHN+211) THEN
17240 C...pi+_tc
17241         FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17242         DO 350 I=1,MDCY(KC,3)
17243           IDC=I+MDCY(KC,2)-1
17244           IF(MDME(IDC,1).LT.0) GOTO 350
17245           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17246           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17247           PM3=0D0
17248           IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17249           RM1=PM1**2/SH
17250           RM2=PM2**2/SH
17251           RM3=PM3**2/SH
17252           IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17253           WID2=1D0
17254 C...pi_tc -> f + f'.
17255           FCOF=1D0
17256           IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17257 C...pi_tc+ -> W b b~
17258           IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17259             FCOF=3D0*RADC
17260             XMT2=PMAS(6,1)**2/SH
17261             FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
17262             KFC3=PYCOMP(KFDP(IDC,3))
17263             CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17264             CHECK = SQRT(RM1)
17265             T0 = (1D0-CHECK**2)*
17266      &      (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17267      &      (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17268             T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17269      &      -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17270             T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17271             WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17272      &      +T3*LOG(CHECK))
17273             IF(KFLR.GT.0) THEN
17274                WID2=WIDS(24,2)
17275             ELSE
17276                WID2=WIDS(24,3)
17277             ENDIF
17278           ELSE
17279             FCOF=1D0
17280             IKA=IABS(KFDP(IDC,1))
17281             IF(IKA.LT.10) FCOF=3D0*RADC
17282             HM1=PM1
17283             HM2=PM2
17284             IF(I.GE.1.AND.I.LE.5) THEN
17285               IF(I.LE.2) THEN
17286                 FCOF=FCOF*PARP(145)**2
17287               ELSEIF(I.LE.4) THEN
17288                 FCOF=FCOF*PARP(146)**2
17289               ELSEIF(I.EQ.5) THEN
17290                 FCOF=FCOF*PARP(147)**2
17291               ENDIF
17292               HM1=PYMRUN(KFDP(IDC,1),SH)
17293               HM2=PYMRUN(KFDP(IDC,2),SH)
17294             ELSEIF(I.EQ.8) THEN
17295               FCOF=FCOF*PARP(148)**2
17296             ENDIF
17297             WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17298      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17299           ENDIF
17300           WDTP(I)=FUDGE*WDTP(I)
17301           WDTP(0)=WDTP(0)+WDTP(I)
17302           IF(MDME(IDC,1).GT.0) THEN
17303             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17304             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17305             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17306             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17307           ENDIF
17308   350     CONTINUE
17309
17310       ELSEIF(KFLA.EQ.KTECHN+331) THEN
17311 C...Techni-eta.
17312         FAC=(SH/PARP(46)**2)*SHR
17313         DO 360 I=1,MDCY(KC,3)
17314           IDC=I+MDCY(KC,2)-1
17315           IF(MDME(IDC,1).LT.0) GOTO 360
17316           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17317           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17318           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17319           WID2=1D0
17320           IF(I.LE.2) THEN
17321             WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17322             IF(I.EQ.2) WID2=WIDS(6,1)
17323           ELSE
17324             WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17325           ENDIF
17326           WDTP(I)=FUDGE*WDTP(I)
17327           WDTP(0)=WDTP(0)+WDTP(I)
17328           IF(MDME(IDC,1).GT.0) THEN
17329             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17330             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17331             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17332             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17333           ENDIF
17334   360   CONTINUE
17335
17336       ELSEIF(KFLA.EQ.KTECHN+113) THEN
17337 C...Techni-rho0:
17338         ALPRHT=2.91D0*(3D0/PARP(144))
17339         FAC=(ALPRHT/12D0)*SHR
17340         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17341         SQMZ=PMAS(23,1)**2
17342         SQMW=PMAS(24,1)**2
17343         SHP=SH
17344         CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17345         GMMZ=SHR*WDTPP(0)
17346         XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17347         BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17348         BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17349         DO 370 I=1,MDCY(KC,3)
17350           IDC=I+MDCY(KC,2)-1
17351           IF(MDME(IDC,1).LT.0) GOTO 370
17352           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17353           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17354           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17355           WID2=1D0
17356           IF(I.EQ.1) THEN
17357 C...rho_tc0 -> W+ + W-.
17358             WDTP(I)=FAC*PARP(141)**4*
17359      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17360             WID2=WIDS(24,1)
17361           ELSEIF(I.EQ.2) THEN
17362 C...rho_tc0 -> W+ + pi_tc-.
17363             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17364      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17365      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17366      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17367      &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17368             WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17369           ELSEIF(I.EQ.3) THEN
17370 C...rho_tc0 -> pi_tc+ + W-.
17371             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17372      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17373      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17374      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17375      &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17376             WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17377           ELSEIF(I.EQ.4) THEN
17378 C...rho_tc0 -> pi_tc+ + pi_tc-.
17379             WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17380      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17381             WID2=WIDS(PYCOMP(KTECHN+211),1)
17382           ELSEIF(I.EQ.5) THEN
17383 C...rho_tc0 -> gamma + pi_tc0
17384             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17385      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17386      &      SHR**3
17387             WID2=WIDS(PYCOMP(KTECHN+111),2)
17388           ELSEIF(I.EQ.6) THEN
17389 C...rho_tc0 -> gamma + pi_tc0'
17390             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17391      &      (1D0-PARP(139)**2)/24D0/PARP(137)**2*SHR**3
17392             WID2=WIDS(PYCOMP(KTECHN+221),2)
17393           ELSEIF(I.EQ.7) THEN
17394 C...rho_tc0 -> Z0 + pi_tc0
17395             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17396      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17397      &      XW/XW1*SHR**3
17398             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17399           ELSEIF(I.EQ.8) THEN
17400 C...rho_tc0 -> Z0 + pi_tc0'
17401             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17402      &      (1D0-PARP(139)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17403      &      XW/XW1*SHR**3
17404             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17405           ELSE
17406 C...rho_tc0 -> f + fbar.
17407             WID2=1D0
17408             IF(I.LE.16) THEN
17409               IA=I-8
17410               FCOF=3D0*RADC
17411               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17412             ELSE
17413               IA=I-6
17414               FCOF=1D0
17415               IF(IA.GE.17) WID2=WIDS(IA,1)
17416             ENDIF
17417             EI=KCHG(IA,1)/3D0
17418             AI=SIGN(1D0,EI+0.1D0)
17419             VI=AI-4D0*EI*XWV
17420             VALI=0.5D0*(VI+AI)
17421             VARI=0.5D0*(VI-AI)
17422             WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17423      &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17424      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17425      &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17426           ENDIF
17427           WDTP(I)=FUDGE*WDTP(I)
17428           WDTP(0)=WDTP(0)+WDTP(I)
17429           IF(MDME(IDC,1).GT.0) THEN
17430             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17431             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17432             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17433             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17434           ENDIF
17435   370   CONTINUE
17436
17437       ELSEIF(KFLA.EQ.KTECHN+213) THEN
17438 C...Techni-rho+/-:
17439         ALPRHT=2.91D0*(3D0/PARP(144))
17440         FAC=(ALPRHT/12D0)*SHR
17441         SQMZ=PMAS(23,1)**2
17442         SQMW=PMAS(24,1)**2
17443         SHP=SH
17444         CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17445         GMMW=SHR*WDTPP(0)
17446         FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17447      &  (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17448         DO 380 I=1,MDCY(KC,3)
17449           IDC=I+MDCY(KC,2)-1
17450           IF(MDME(IDC,1).LT.0) GOTO 380
17451           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17452           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17453           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17454           WID2=1D0
17455           IF(I.EQ.1) THEN
17456 C...rho_tc+ -> W+ + Z0.
17457             WDTP(I)=FAC*PARP(141)**4*
17458      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17459             IF(KFLR.GT.0) THEN
17460               WID2=WIDS(24,2)*WIDS(23,2)
17461             ELSE
17462               WID2=WIDS(24,3)*WIDS(23,2)
17463             ENDIF
17464           ELSEIF(I.EQ.2) THEN
17465 C...rho_tc+ -> W+ + pi_tc0.
17466             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17467      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17468      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17469      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17470      &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17471             IF(KFLR.GT.0) THEN
17472               WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17473             ELSE
17474               WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17475             ENDIF
17476           ELSEIF(I.EQ.3) THEN
17477 C...rho_tc+ -> pi_tc+ + Z0.
17478             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17479      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17480      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17481      &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17482      &      (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARP(138)**2*SHR**3+
17483      &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17484      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17485      &      SHR**3*XW/XW1
17486             IF(KFLR.GT.0) THEN
17487               WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17488             ELSE
17489               WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17490             ENDIF
17491           ELSEIF(I.EQ.4) THEN
17492 C...rho_tc+ -> pi_tc+ + pi_tc0.
17493             WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17494      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17495             IF(KFLR.GT.0) THEN
17496               WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17497             ELSE
17498               WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17499             ENDIF
17500           ELSEIF(I.EQ.5) THEN
17501 C...rho_tc+ -> pi_tc+ + gamma
17502             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17503      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17504      &      SHR**3
17505             IF(KFLR.GT.0) THEN
17506               WID2=WIDS(PYCOMP(KTECHN+211),2)
17507             ELSE
17508               WID2=WIDS(PYCOMP(KTECHN+211),3)
17509             ENDIF
17510           ELSEIF(I.EQ.6) THEN
17511 C...rho_tc+ -> W+ + pi_tc0'
17512             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17513      &      (1D0-PARP(139)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3
17514             IF(KFLR.GT.0) THEN
17515               WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17516             ELSE
17517               WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17518             ENDIF
17519           ELSE
17520 C...rho_tc+ -> f + fbar'.
17521             IA=I-6
17522             WID2=1D0
17523             IF(IA.LE.16) THEN
17524               FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17525               IF(KFLR.GT.0) THEN
17526                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17527                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17528                 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17529               ELSE
17530                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17531                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17532                 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17533               ENDIF
17534             ELSE
17535               FCOF=1D0
17536               IF(KFLR.GT.0) THEN
17537                 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17538               ELSE
17539                 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17540               ENDIF
17541             ENDIF
17542             WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17543      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17544           ENDIF
17545           WDTP(I)=FUDGE*WDTP(I)
17546           WDTP(0)=WDTP(0)+WDTP(I)
17547           IF(MDME(IDC,1).GT.0) THEN
17548             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17549             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17550             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17551             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17552           ENDIF
17553   380   CONTINUE
17554
17555       ELSEIF(KFLA.EQ.KTECHN+223) THEN
17556 C...Techni-omega:
17557         ALPRHT=2.91D0*(3D0/PARP(144))
17558         FAC=(ALPRHT/12D0)*SHR
17559         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
17560         SQMZ=PMAS(23,1)**2
17561         SHP=SH
17562         CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17563         GMMZ=SHR*WDTPP(0)
17564         BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17565         BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17566         DO 390 I=1,MDCY(KC,3)
17567           IDC=I+MDCY(KC,2)-1
17568           IF(MDME(IDC,1).LT.0) GOTO 390
17569           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17570           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17571           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17572           WID2=1D0
17573           IF(I.EQ.1) THEN
17574 C...omega_tc0 -> gamma + pi_tc0.
17575             WDTP(I)=AEM/24D0/PARP(137)**2*(1D0-PARP(141)**2)*
17576      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17577             WID2=WIDS(PYCOMP(KTECHN+111),2)
17578           ELSEIF(I.EQ.2) THEN
17579 C...omega_tc0 -> Z0 + pi_tc0
17580             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17581      &      (1D0-PARP(141)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17582      &      XW/XW1*SHR**3
17583             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17584           ELSEIF(I.EQ.3) THEN
17585 C...omega_tc0 -> gamma + pi_tc0'
17586             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17587      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17588      &      SHR**3
17589             WID2=WIDS(PYCOMP(KTECHN+221),2)
17590           ELSEIF(I.EQ.4) THEN
17591 C...omega_tc0 -> Z0 + pi_tc0'
17592             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17593      &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17594      &      XW/XW1*SHR**3
17595             WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17596           ELSEIF(I.EQ.5) THEN
17597 C...omega_tc0 -> W+ + pi_tc-
17598             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17599      &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17600      &      FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17601      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17602             WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17603           ELSEIF(I.EQ.6) THEN
17604 C...omega_tc0 -> pi_tc+ + W-
17605             WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17606      &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17607      &      FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17608      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17609             WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17610           ELSEIF(I.EQ.7) THEN
17611 C...omega_tc0 -> W+ + W-.
17612             WDTP(I)=FAC*PARP(141)**4*PARP(140)**2*
17613      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17614             WID2=WIDS(24,1)
17615           ELSEIF(I.EQ.8) THEN
17616 C...omega_tc0 -> pi_tc+ + pi_tc-.
17617             WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARP(140)**2*
17618      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17619             WID2=WIDS(PYCOMP(KTECHN+211),1)
17620           ELSE
17621 C...omega_tc0 -> f + fbar.
17622             WID2=1D0
17623             IF(I.LE.14) THEN
17624               IA=I-8
17625               FCOF=3D0*RADC
17626               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17627             ELSE
17628               IA=I-6
17629               FCOF=1D0
17630               IF(IA.GE.17) WID2=WIDS(IA,1)
17631             ENDIF
17632             EI=KCHG(IA,1)/3D0
17633             AI=SIGN(1D0,EI+0.1D0)
17634             VI=AI-4D0*EI*XWV
17635             VALI=0.5D0*(VI+AI)
17636             VARI=0.5D0*(VI-AI)
17637             WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17638      &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17639      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17640      &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17641           ENDIF
17642           WDTP(I)=FUDGE*WDTP(I)
17643           WDTP(0)=WDTP(0)+WDTP(I)
17644           IF(MDME(IDC,1).GT.0) THEN
17645             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17646             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17647             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17648             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17649           ENDIF
17650   390   CONTINUE
17651
17652 C.....V8 -> quark anti-quark
17653       ELSEIF(KFLA.EQ.KTECHN+100021) THEN
17654         FAC=AS/6D0*SHR
17655         TANT3=ABS(PARP(155))
17656         IF(PARP(155).GT.0) THEN
17657           IMDL=1
17658         ELSE
17659           IMDL=2
17660         ENDIF
17661         DO 400 I=1,MDCY(KC,3)
17662           IDC=I+MDCY(KC,2)-1
17663           IF(MDME(IDC,1).LT.0) GOTO 400
17664           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17665           RM1=PM1**2/SH
17666           IF(RM1.GT.0.25D0) GOTO 400
17667           WID2=1D0
17668           IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17669             FMIX=1D0/TANT3**2
17670           ELSE
17671             FMIX=TANT3**2
17672           ENDIF
17673           WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
17674           IF(I.EQ.6) WID2=WIDS(6,1)
17675           WDTP(I)=FUDGE*WDTP(I)
17676           WDTP(0)=WDTP(0)+WDTP(I)
17677           IF(MDME(IDC,1).GT.0) THEN
17678             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17679             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17680             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17681             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17682           ENDIF
17683   400   CONTINUE
17684
17685       ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
17686         FAC=(1D0/(4D0*PARU(1)*PARP(142)**2))*SHR
17687         CLEBF=0D0
17688         DO 410 I=1,MDCY(KC,3)
17689           IDC=I+MDCY(KC,2)-1
17690           IF(MDME(IDC,1).LT.0) GOTO 410
17691           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17692           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17693           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
17694           WID2=1D0
17695 C...pi_tc -> g + g
17696           IF(I.EQ.7) THEN
17697             IF(KFLA.EQ.KTECHN+100111) THEN
17698               CLEBG=4D0/3D0
17699             ELSE
17700               CLEBG=5D0/3D0
17701             ENDIF
17702             FACP=(AS/(8D0*PARU(1))*PARP(144)/PARP(142))**2
17703      &      /(2D0*PARU(1))*SH*SHR*CLEBG
17704             WDTP(I)=FACP
17705           ELSE
17706 C...pi_tc -> f + fbar.
17707             IF(I.EQ.6) WID2=WIDS(6,1)
17708             FCOF=1D0
17709             IKA=IABS(KFDP(IDC,1))
17710             IF(IKA.LT.10) FCOF=3D0*RADC
17711             HM1=PYMRUN(KFDP(IDC,1),SH)
17712             WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
17713      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17714           ENDIF
17715           WDTP(I)=FUDGE*WDTP(I)
17716           WDTP(0)=WDTP(0)+WDTP(I)
17717           IF(MDME(IDC,1).GT.0) THEN
17718             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17719             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17720             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17721             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17722           ENDIF
17723   410   CONTINUE
17724
17725       ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
17726         FAC=AS/6D0*SHR
17727         ALPRHT=2.91D0*(3D0/PARP(144))
17728         TANT3=ABS(PARP(155))
17729         SIN2T=2D0*TANT3/(TANT3**2+1D0)
17730         SINT3=TANT3/SQRT(TANT3**2+1D0)
17731         CSXPP=1D0/SQRT(2D0)
17732         RM82=PARP(156)**2
17733         X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
17734      &  1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)
17735         X21=1D-6
17736         X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
17737      &  SINT3**2)*2D0
17738         X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
17739      &  SINT3**2)*2D0
17740         IF(PARP(155).GT.0) THEN
17741           IMDL=1
17742         ELSE
17743           IMDL=2
17744         ENDIF
17745         DO 420 I=1,MDCY(KC,3)
17746           IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
17747      &    KFLA.EQ.KTECHN+300113)) GOTO 420
17748           IDC=I+MDCY(KC,2)-1
17749           IF(MDME(IDC,1).LT.0) GOTO 420
17750           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17751           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17752           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
17753           WID2=1D0
17754           IF(I.LE.6) THEN
17755             IF(I.EQ.6) WID2=WIDS(6,1)
17756             XIG=1D0
17757             IF(KFLA.EQ.KTECHN+200113) THEN
17758               XIG=0D0
17759               XIJ=X12
17760             ELSEIF(KFLA.EQ.KTECHN+300113) THEN
17761               XIG=0D0
17762               XIJ=X21
17763             ELSEIF(KFLA.EQ.KTECHN+100113) THEN
17764               XIJ=X11
17765             ELSE
17766               XIJ=X22
17767             ENDIF
17768             IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17769               FMIX=1D0/TANT3/SIN2T
17770             ELSE
17771               FMIX=-TANT3/SIN2T
17772             ENDIF
17773             XFAC=(XIG+FMIX*XIJ)**2
17774             WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
17775           ELSEIF(I.EQ.7) THEN
17776             WDTP(I)=SHR*AS**2/(2D0*ALPRHT)
17777           ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
17778             PSH=SHR*(1D0-RM1)/2D0
17779             WDTP(I)=AS/9D0*PSH**3/RM82
17780             IF(I.EQ.8) THEN
17781               WDTP(I)=2D0*WDTP(I)*CSXPP**2
17782               WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17783             ELSE
17784               WDTP(I)=5D0*WDTP(I)
17785               WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17786             ENDIF
17787           ENDIF
17788           WDTP(I)=FUDGE*WDTP(I)
17789           WDTP(0)=WDTP(0)+WDTP(I)
17790           IF(MDME(IDC,1).GT.0) THEN
17791             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17792             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17793             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17794             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17795           ENDIF
17796   420   CONTINUE
17797
17798       ELSEIF(KFLA.EQ.KEXCIT+1) THEN
17799 C...d* excited quark.
17800         FAC=(SH/PARU(155)**2)*SHR
17801         DO 430 I=1,MDCY(KC,3)
17802           IDC=I+MDCY(KC,2)-1
17803           IF(MDME(IDC,1).LT.0) GOTO 430
17804           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17805           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17806           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
17807           WID2=1D0
17808           IF(I.EQ.1) THEN
17809 C...d* -> g + d.
17810             WDTP(I)=FAC*AS*PARU(159)**2/3D0
17811             WID2=1D0
17812           ELSEIF(I.EQ.2) THEN
17813 C...d* -> gamma + d.
17814             QF=-PARU(157)/2D0+PARU(158)/6D0
17815             WDTP(I)=FAC*AEM*QF**2/4D0
17816             WID2=1D0
17817           ELSEIF(I.EQ.3) THEN
17818 C...d* -> Z0 + d.
17819             QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17820             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17821      &      (1D0-RM1)**2*(2D0+RM1)
17822             WID2=WIDS(23,2)
17823           ELSEIF(I.EQ.4) THEN
17824 C...d* -> W- + u.
17825             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17826      &      (1D0-RM1)**2*(2D0+RM1)
17827             IF(KFLR.GT.0) WID2=WIDS(24,3)
17828             IF(KFLR.LT.0) WID2=WIDS(24,2)
17829           ENDIF
17830           WDTP(I)=FUDGE*WDTP(I)
17831           WDTP(0)=WDTP(0)+WDTP(I)
17832           IF(MDME(IDC,1).GT.0) THEN
17833             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17834             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17835             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17836             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17837           ENDIF
17838   430   CONTINUE
17839
17840       ELSEIF(KFLA.EQ.KEXCIT+2) THEN
17841 C...u* excited quark.
17842         FAC=(SH/PARU(155)**2)*SHR
17843         DO 440 I=1,MDCY(KC,3)
17844           IDC=I+MDCY(KC,2)-1
17845           IF(MDME(IDC,1).LT.0) GOTO 440
17846           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17847           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17848           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
17849           WID2=1D0
17850           IF(I.EQ.1) THEN
17851 C...u* -> g + u.
17852             WDTP(I)=FAC*AS*PARU(159)**2/3D0
17853             WID2=1D0
17854           ELSEIF(I.EQ.2) THEN
17855 C...u* -> gamma + u.
17856             QF=PARU(157)/2D0+PARU(158)/6D0
17857             WDTP(I)=FAC*AEM*QF**2/4D0
17858             WID2=1D0
17859           ELSEIF(I.EQ.3) THEN
17860 C...u* -> Z0 + u.
17861             QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17862             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17863      &      (1D0-RM1)**2*(2D0+RM1)
17864             WID2=WIDS(23,2)
17865           ELSEIF(I.EQ.4) THEN
17866 C...u* -> W+ + d.
17867             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17868      &      (1D0-RM1)**2*(2D0+RM1)
17869             IF(KFLR.GT.0) WID2=WIDS(24,2)
17870             IF(KFLR.LT.0) WID2=WIDS(24,3)
17871           ENDIF
17872           WDTP(I)=FUDGE*WDTP(I)
17873           WDTP(0)=WDTP(0)+WDTP(I)
17874           IF(MDME(IDC,1).GT.0) THEN
17875             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17876             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17877             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17878             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17879           ENDIF
17880   440   CONTINUE
17881
17882       ELSEIF(KFLA.EQ.KEXCIT+11) THEN
17883 C...e* excited lepton.
17884         FAC=(SH/PARU(155)**2)*SHR
17885         DO 450 I=1,MDCY(KC,3)
17886           IDC=I+MDCY(KC,2)-1
17887           IF(MDME(IDC,1).LT.0) GOTO 450
17888           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17889           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17890           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
17891           WID2=1D0
17892           IF(I.EQ.1) THEN
17893 C...e* -> gamma + e.
17894             QF=-PARU(157)/2D0-PARU(158)/2D0
17895             WDTP(I)=FAC*AEM*QF**2/4D0
17896             WID2=1D0
17897           ELSEIF(I.EQ.2) THEN
17898 C...e* -> Z0 + e.
17899             QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17900             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17901      &      (1D0-RM1)**2*(2D0+RM1)
17902             WID2=WIDS(23,2)
17903           ELSEIF(I.EQ.3) THEN
17904 C...e* -> W- + nu.
17905             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17906      &      (1D0-RM1)**2*(2D0+RM1)
17907             IF(KFLR.GT.0) WID2=WIDS(24,3)
17908             IF(KFLR.LT.0) WID2=WIDS(24,2)
17909           ENDIF
17910           WDTP(I)=FUDGE*WDTP(I)
17911           WDTP(0)=WDTP(0)+WDTP(I)
17912           IF(MDME(IDC,1).GT.0) THEN
17913             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17914             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17915             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17916             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17917           ENDIF
17918   450   CONTINUE
17919
17920       ELSEIF(KFLA.EQ.KEXCIT+12) THEN
17921 C...nu*_e excited neutrino.
17922         FAC=(SH/PARU(155)**2)*SHR
17923         DO 460 I=1,MDCY(KC,3)
17924           IDC=I+MDCY(KC,2)-1
17925           IF(MDME(IDC,1).LT.0) GOTO 460
17926           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17927           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17928           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
17929           WID2=1D0
17930           IF(I.EQ.1) THEN
17931 C...nu*_e -> Z0 + nu*_e.
17932             QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17933             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17934      &      (1D0-RM1)**2*(2D0+RM1)
17935             WID2=WIDS(23,2)
17936           ELSEIF(I.EQ.2) THEN
17937 C...nu*_e -> W+ + e.
17938             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17939      &      (1D0-RM1)**2*(2D0+RM1)
17940             IF(KFLR.GT.0) WID2=WIDS(24,2)
17941             IF(KFLR.LT.0) WID2=WIDS(24,3)
17942           ENDIF
17943           WDTP(I)=FUDGE*WDTP(I)
17944           WDTP(0)=WDTP(0)+WDTP(I)
17945           IF(MDME(IDC,1).GT.0) THEN
17946             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17947             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17948             WDTE(I,0)=WDTE(I,MDME(IDC,1))
17949             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17950           ENDIF
17951   460   CONTINUE
17952
17953       ELSEIF(KFLA.EQ.KDIMEN+39) THEN
17954 C...G* (graviton resonance):
17955         FAC=(PARP(50)**2/PARU(1))*SHR
17956         DO 470 I=1,MDCY(KC,3)
17957           IDC=I+MDCY(KC,2)-1
17958           IF(MDME(IDC,1).LT.0) GOTO 470
17959           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17960           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17961           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
17962           WID2=1D0
17963           IF(I.LE.8) THEN
17964 C...G* -> q + qbar
17965             FCOF=3D0*RADC
17966             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17967      &      PYHFTH(SH,SH*RM1,1D0)
17968             WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17969      &      (1D0+8D0*RM1/3D0)/320D0
17970             IF(I.EQ.6) WID2=WIDS(6,1)
17971             IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
17972           ELSEIF(I.LE.16) THEN
17973 C...G* -> l+ + l-, nu + nubar
17974             FCOF=1D0
17975             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17976      &      (1D0+8D0*RM1/3D0)/320D0
17977             IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
17978           ELSEIF(I.EQ.17) THEN
17979 C...G* -> g + g.
17980             WDTP(I)=FAC/20D0
17981           ELSEIF(I.EQ.18) THEN
17982 C...G* -> gamma + gamma.
17983             WDTP(I)=FAC/160D0
17984           ELSEIF(I.EQ.19) THEN
17985 C...G* -> Z0 + Z0.
17986             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17987      &      14D0*RM1/3D0+4D0*RM1**2)/160D0
17988             WID2=WIDS(23,1)
17989           ELSEIF(I.EQ.20) THEN
17990 C...G* -> W+ + W-.
17991             WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17992      &      14D0*RM1/3D0+4D0*RM1**2)/80D0
17993             WID2=WIDS(24,1)
17994           ENDIF
17995           WDTP(I)=FUDGE*WDTP(I)
17996           WDTP(0)=WDTP(0)+WDTP(I)
17997           IF(MDME(IDC,1).GT.0) THEN
17998             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17999             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18000             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18001             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18002           ENDIF
18003   470   CONTINUE
18004
18005       ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18006 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18007         PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18008         FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18009         DO 480 I=1,MDCY(KC,3)
18010           IDC=I+MDCY(KC,2)-1
18011           IF(MDME(IDC,1).LT.0) GOTO 480
18012           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18013           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18014           PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18015           IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18016           WID2=1D0
18017           IF(I.LE.9) THEN
18018 C...nu_lR -> l- qbar q'
18019             FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18020             IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18021           ELSEIF(I.LE.18) THEN
18022 C...nu_lR -> l+ q qbar'
18023             FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18024             IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18025           ELSE
18026 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18027             FCOF=1D0
18028             WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18029           ENDIF
18030           X=(PM1+PM2+PM3)/SHR
18031           FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18032           Y=(SHR/PMWR)**2
18033           FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18034           WDTP(I)=FAC*FCOF*FX*FY
18035           WDTP(I)=FUDGE*WDTP(I)
18036           WDTP(0)=WDTP(0)+WDTP(I)
18037           IF(MDME(IDC,1).GT.0) THEN
18038             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18039             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18040             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18041             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18042           ENDIF
18043   480   CONTINUE
18044
18045       ELSEIF(KFLA.EQ.9900023) THEN
18046 C...Z_R0:
18047         FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18048         DO 490 I=1,MDCY(KC,3)
18049           IDC=I+MDCY(KC,2)-1
18050           IF(MDME(IDC,1).LT.0) GOTO 490
18051           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18052           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18053           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18054           WID2=1D0
18055           SYMMET=1D0
18056           IF(I.LE.6) THEN
18057 C...Z_R0 -> q + qbar
18058             EF=KCHG(I,1)/3D0
18059             AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18060             VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18061             FCOF=3D0*RADC
18062             IF(I.EQ.6) WID2=WIDS(6,1)
18063           ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18064 C...Z_R0 -> l+ + l-
18065             AF=-(1D0-2D0*XW)
18066             VF=-1D0+4D0*XW
18067             FCOF=1D0
18068           ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18069 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18070             AF=-2D0*XW
18071             VF=0D0
18072             FCOF=1D0
18073             SYMMET=0.5D0
18074           ELSEIF(I.LE.15) THEN
18075 C...Z0 -> nu_R + nu_R, assumed Majorana.
18076             AF=2D0*XW1
18077             VF=0D0
18078             FCOF=1D0
18079             WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18080             SYMMET=0.5D0
18081           ENDIF
18082           WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18083      &    SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18084           WDTP(I)=FUDGE*WDTP(I)
18085           WDTP(0)=WDTP(0)+WDTP(I)
18086           IF(MDME(IDC,1).GT.0) THEN
18087             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18088             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18089             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18090             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18091           ENDIF
18092   490   CONTINUE
18093
18094       ELSEIF(KFLA.EQ.9900024) THEN
18095 C...W_R+/-:
18096         FAC=(AEM/(24D0*XW))*SHR
18097         DO 500 I=1,MDCY(KC,3)
18098           IDC=I+MDCY(KC,2)-1
18099           IF(MDME(IDC,1).LT.0) GOTO 500
18100           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18101           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18102           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18103           WID2=1D0
18104           IF(I.LE.9) THEN
18105 C...W_R+/- -> q + qbar'
18106             FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18107             IF(KFLR.GT.0) THEN
18108               IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18109             ELSE
18110               IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18111             ENDIF
18112           ELSEIF(I.LE.12) THEN
18113 C...W_R+/- -> l+/- + nu_R
18114             FCOF=1D0
18115           ENDIF
18116           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18117      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18118           WDTP(I)=FUDGE*WDTP(I)
18119           WDTP(0)=WDTP(0)+WDTP(I)
18120           IF(MDME(IDC,1).GT.0) THEN
18121             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18122             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18123             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18124             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18125           ENDIF
18126   500  CONTINUE
18127
18128       ELSEIF(KFLA.EQ.9900041) THEN
18129 C...H_L++/--:
18130         FAC=(1D0/(8D0*PARU(1)))*SHR
18131         DO 510 I=1,MDCY(KC,3)
18132           IDC=I+MDCY(KC,2)-1
18133           IF(MDME(IDC,1).LT.0) GOTO 510
18134           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18135           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18136           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18137           WID2=1D0
18138           IF(I.LE.6) THEN
18139 C...H_L++/-- -> l+/- + l'+/-
18140             FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18141      &      (IABS(KFDP(IDC,2))-9)/2)**2
18142             IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18143           ELSEIF(I.EQ.7) THEN
18144 C...H_L++/-- -> W_L+/- + W_L+/-
18145             FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18146      &      (3D0*RM1+0.25D0/RM1-1D0)
18147             WID2=WIDS(24,4+(1-KFLS)/2)
18148           ENDIF
18149           WDTP(I)=FAC*FCOF*
18150      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18151           WDTP(I)=FUDGE*WDTP(I)
18152           WDTP(0)=WDTP(0)+WDTP(I)
18153           IF(MDME(IDC,1).GT.0) THEN
18154             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18155             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18156             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18157             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18158           ENDIF
18159   510   CONTINUE
18160
18161       ELSEIF(KFLA.EQ.9900042) THEN
18162 C...H_R++/--:
18163         FAC=(1D0/(8D0*PARU(1)))*SHR
18164         DO 520 I=1,MDCY(KC,3)
18165           IDC=I+MDCY(KC,2)-1
18166           IF(MDME(IDC,1).LT.0) GOTO 520
18167           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18168           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18169           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18170           WID2=1D0
18171           IF(I.LE.6) THEN
18172 C...H_R++/-- -> l+/- + l'+/-
18173             FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18174      &      (IABS(KFDP(IDC,2))-9)/2)**2
18175             IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18176           ELSEIF(I.EQ.7) THEN
18177 C...H_R++/-- -> W_R+/- + W_R+/-
18178             FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18179             WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18180           ENDIF
18181           WDTP(I)=FAC*FCOF*
18182      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18183           WDTP(I)=FUDGE*WDTP(I)
18184           WDTP(0)=WDTP(0)+WDTP(I)
18185           IF(MDME(IDC,1).GT.0) THEN
18186             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18187             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18188             WDTE(I,0)=WDTE(I,MDME(IDC,1))
18189             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18190           ENDIF
18191   520  CONTINUE
18192
18193       ENDIF
18194       MINT(61)=0
18195       MINT(62)=0
18196       MINT(63)=0
18197       RETURN
18198       END
18199
18200 C***********************************************************************
18201
18202 C...PYOFSH
18203 C...Calculates partial width and differential cross-section maxima
18204 C...of channels/processes not allowed on mass-shell, and selects
18205 C...masses in such channels/processes.
18206
18207       SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18208
18209 C...Double precision and integer declarations.
18210       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18211       IMPLICIT INTEGER(I-N)
18212       INTEGER PYK,PYCHGE,PYCOMP
18213 C...Commonblocks.
18214       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18215       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18216       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18217       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18218       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18219       COMMON/PYINT1/MINT(400),VINT(400)
18220       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18221       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18222       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18223      &/PYINT2/,/PYINT5/
18224 C...Local arrays.
18225       DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18226      &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18227      &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:300),
18228      &WDTE(0:300,0:5)
18229
18230 C...Find if particles equal, maximum mass, matrix elements, etc.
18231       MINT(51)=0
18232       ISUB=MINT(1)
18233       KFD(1)=IABS(KFD1)
18234       KFD(2)=IABS(KFD2)
18235       MEQL=0
18236       IF(KFD(1).EQ.KFD(2)) MEQL=1
18237       MLM=0
18238       IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18239       IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18240         NOFF=44
18241         PMMX=PMMO
18242       ELSE
18243         NOFF=40
18244         PMMX=VINT(1)
18245         IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18246       ENDIF
18247       MMED=0
18248       IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18249      &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18250       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18251      &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18252       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18253      &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18254       LOOP=1
18255
18256 C...Find where Breit-Wigners are required, else select discrete masses.
18257   100 DO 110 I=1,2
18258         KFCA=PYCOMP(KFD(I))
18259         IF(KFCA.GT.0) THEN
18260           PMD(I)=PMAS(KFCA,1)
18261           PGD(I)=PMAS(KFCA,2)
18262         ELSE
18263           PMD(I)=0D0
18264           PGD(I)=0D0
18265         ENDIF
18266         IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18267           MBW(I)=0
18268           PMG(I)=PMD(I)
18269           RMG(I)=(PMG(I)/PMMX)**2
18270         ELSE
18271           MBW(I)=1
18272         ENDIF
18273   110 CONTINUE
18274
18275 C...Find allowed mass range and Breit-Wigner parameters.
18276       DO 120 I=1,2
18277         IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18278           PML(I)=PARP(42)
18279           PMU(I)=PMMX-PARP(42)
18280           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18281           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18282         ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18283           ILM=I
18284           IF(MLM.EQ.2) ILM=3-I
18285           PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18286           IF(MBW(3-I).EQ.0) THEN
18287             PMU(I)=PMMX-PMD(3-I)
18288           ELSE
18289             PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18290           ENDIF
18291           IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18292      &    MIN(PMU(I),CKIN(NOFF+2*ILM))
18293           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18294           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18295           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18296           IF(MBW(I).EQ.1) THEN
18297             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18298             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18299             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18300      &      PGD(I)))
18301           ENDIF
18302         ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18303           ILM=I
18304           IF(MLM.EQ.2) ILM=3-I
18305           PML(I)=MAX(CKIN(48+I),PARP(42))
18306           PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18307           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18308           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18309           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18310           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18311           IF(MBW(I).EQ.1) THEN
18312             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18313             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18314             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18315      &      PGD(I)))
18316           ENDIF
18317         ENDIF
18318   120 CONTINUE
18319       IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18320      &THEN
18321         CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18322         MINT(51)=1
18323         RETURN
18324       ENDIF
18325
18326 C...Calculation of partial width of resonance.
18327       IF(MOFSH.EQ.1) THEN
18328
18329 C..If only one integration, pick that to be the inner.
18330         IF(MBW(1).EQ.0) THEN
18331           PM2=PMD(1)
18332           PMD(1)=PMD(2)
18333           PGD(1)=PGD(2)
18334           PML(1)=PML(2)
18335           PMU(1)=PMU(2)
18336         ELSEIF(MBW(2).EQ.0) THEN
18337           PM2=PMD(2)
18338         ENDIF
18339
18340 C...Start outer loop of integration.
18341         IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18342           ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18343           ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18344           NPT2=1
18345           XPT2(1)=1D0
18346           INX2(1)=0
18347           FMAX2=0D0
18348         ENDIF
18349   130   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18350           PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18351           PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18352         ENDIF
18353         RM2=(PM2/PMMX)**2
18354
18355 C...Start inner loop of integration.
18356         PML1=PML(1)
18357         PMU1=MIN(PMU(1),PMMX-PM2)
18358         IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18359         ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18360         ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18361         IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18362           FUNC2=0D0
18363           GOTO 180
18364         ENDIF
18365         NPT1=1
18366         XPT1(1)=1D0
18367         INX1(1)=0
18368         FMAX1=0D0
18369   140   PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18370         PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18371         RM1=(PM1/PMMX)**2
18372
18373 C...Evaluate function value - inner loop.
18374         FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18375         IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18376         IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18377      &  RM2**2+10D0*RM1*RM2)
18378         IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18379         FPT1(NPT1)=FUNC1
18380
18381 C...Go to next position in inner loop.
18382         IF(NPT1.EQ.1) THEN
18383           NPT1=NPT1+1
18384           XPT1(NPT1)=0D0
18385           INX1(NPT1)=1
18386           GOTO 140
18387         ELSEIF(NPT1.LE.8) THEN
18388           NPT1=NPT1+1
18389           IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18390           ISH1=ISH1+1
18391           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18392           INX1(NPT1)=INX1(ISH1)
18393           INX1(ISH1)=NPT1
18394           GOTO 140
18395         ELSEIF(NPT1.LT.100) THEN
18396           ISN1=ISH1
18397   150     ISH1=ISH1+1
18398           IF(ISH1.GT.NPT1) ISH1=2
18399           IF(ISH1.EQ.ISN1) GOTO 160
18400           DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18401           IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18402           NPT1=NPT1+1
18403           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18404           INX1(NPT1)=INX1(ISH1)
18405           INX1(ISH1)=NPT1
18406           GOTO 140
18407         ENDIF
18408
18409 C...Calculate integral over inner loop.
18410   160   FSUM1=0D0
18411         DO 170 IPT1=2,NPT1
18412           FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18413      &    (XPT1(INX1(IPT1))-XPT1(IPT1))
18414   170   CONTINUE
18415         FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18416   180   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18417           IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18418           FPT2(NPT2)=FUNC2
18419
18420 C...Go to next position in outer loop.
18421           IF(NPT2.EQ.1) THEN
18422             NPT2=NPT2+1
18423             XPT2(NPT2)=0D0
18424             INX2(NPT2)=1
18425             GOTO 130
18426           ELSEIF(NPT2.LE.8) THEN
18427             NPT2=NPT2+1
18428             IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18429             ISH2=ISH2+1
18430             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18431             INX2(NPT2)=INX2(ISH2)
18432             INX2(ISH2)=NPT2
18433             GOTO 130
18434           ELSEIF(NPT2.LT.100) THEN
18435             ISN2=ISH2
18436   190       ISH2=ISH2+1
18437             IF(ISH2.GT.NPT2) ISH2=2
18438             IF(ISH2.EQ.ISN2) GOTO 200
18439             DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18440             IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18441             NPT2=NPT2+1
18442             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18443             INX2(NPT2)=INX2(ISH2)
18444             INX2(ISH2)=NPT2
18445             GOTO 130
18446           ENDIF
18447
18448 C...Calculate integral over outer loop.
18449   200     FSUM2=0D0
18450           DO 210 IPT2=2,NPT2
18451             FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18452      &      (XPT2(INX2(IPT2))-XPT2(IPT2))
18453   210     CONTINUE
18454           FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18455           IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18456         ELSE
18457           FSUM2=FUNC2
18458         ENDIF
18459
18460 C...Save result; second integration for user-selected mass range.
18461         IF(LOOP.EQ.1) WIDW=FSUM2
18462         WID2=FSUM2
18463         IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18464      &  .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18465           LOOP=2
18466           GOTO 100
18467         ENDIF
18468         RET1=WIDW
18469         RET2=WID2/WIDW
18470
18471 C...Select two decay product masses of a resonance.
18472       ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18473   220   DO 230 I=1,2
18474           IF(MBW(I).EQ.0) GOTO 230
18475           PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18476      &    (ATU(I)-ATL(I)))
18477           PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18478           RMG(I)=(PMG(I)/PMMX)**2
18479   230   CONTINUE
18480         IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18481      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18482
18483 C...Weight with matrix element (if none known, use beta factor).
18484         FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18485         IF(MMED.EQ.1) THEN
18486           WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18487         ELSEIF(MMED.EQ.2) THEN
18488           WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18489      &    RMG(2)**2+10D0*RMG(1)*RMG(2))
18490         ELSEIF(MMED.EQ.3) THEN
18491           WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18492         ELSE
18493           WTBE=FLAM
18494         ENDIF
18495         IF(WTBE.LT.PYR(0)) GOTO 220
18496         RET1=PMG(1)
18497         RET2=PMG(2)
18498
18499 C...Find suitable set of masses for initialization of 2 -> 2 processes.
18500       ELSEIF(MOFSH.EQ.3) THEN
18501         IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18502           PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18503           PMG(2)=PMD(2)
18504         ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18505           PMG(1)=PMD(1)
18506           PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18507         ELSE
18508           IDIV=-1
18509   240     IDIV=IDIV+1
18510           PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18511           PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18512           IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18513         ENDIF
18514         RET1=PMG(1)
18515         RET2=PMG(2)
18516
18517 C...Evaluate importance of excluded tails of Breit-Wigners.
18518         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18519      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18520         IF(MEQL.LE.1) THEN
18521           VINT(80)=1D0
18522           DO 250 I=1,2
18523             IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18524      &      PARU(1)
18525   250     CONTINUE
18526         ELSE
18527           VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18528      &    (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18529         ENDIF
18530         IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18531      &  MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18532         IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18533         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18534
18535 C...Pick one particle to be the lighter (if improves efficiency).
18536       ELSEIF(MOFSH.EQ.4) THEN
18537         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18538      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18539   260   IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18540
18541 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18542         DO 270 I=1,2
18543           IF(MBW(I).EQ.0) GOTO 270
18544           PMV=PMU(I)
18545           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18546           ATV=ATU(I)
18547           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18548           RBR=PYR(0)
18549           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18550      &    ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18551           IF(RBR.LT.0.8D0) THEN
18552             PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18553             PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18554           ELSEIF(RBR.LT.0.9D0) THEN
18555             PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18556           ELSEIF(RBR.LT.1.5D0) THEN
18557             PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18558           ELSE
18559             PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18560      &      (PMV**2-PML(I)**2))))
18561           ENDIF
18562   270   CONTINUE
18563         IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18564      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18565           IF(MINT(48).EQ.1) THEN
18566             NGEN(0,1)=NGEN(0,1)+1
18567             NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18568             GOTO 260
18569           ELSE
18570             MINT(51)=1
18571             RETURN
18572           ENDIF
18573         ENDIF
18574         RET1=PMG(1)
18575         RET2=PMG(2)
18576
18577 C...Give weight for selected mass distribution.
18578         VINT(80)=1D0
18579         DO 280 I=1,2
18580           IF(MBW(I).EQ.0) GOTO 280
18581           PMV=PMU(I)
18582           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18583           ATV=ATU(I)
18584           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18585           F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18586      &    (PMD(I)*PGD(I))**2)/PARU(1)
18587           F1=1D0
18588           F2=1D0/PMG(I)**2
18589           F3=1D0/PMG(I)**4
18590           FI0=(ATV-ATL(I))/PARU(1)
18591           FI1=PMV**2-PML(I)**2
18592           FI2=2D0*LOG(PMV/PML(I))
18593           FI3=1D0/PML(I)**2-1D0/PMV**2
18594           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18595      &    ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18596             VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18597      &      5D0*F3/FI3))
18598           ELSE
18599             VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18600           ENDIF
18601           VINT(80)=VINT(80)*FI0
18602   280   CONTINUE
18603         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18604       ENDIF
18605
18606       RETURN
18607       END
18608
18609 C***********************************************************************
18610
18611 C...PYRECO
18612 C...Handles the possibility of colour reconnection in W+W- events,
18613 C...Based on the main scenarios of the Sjostrand and Khoze study:
18614 C...I, II, II', intermediate and instantaneous; plus one model
18615 C...along the lines of the Gustafson and Hakkinen: GH.
18616 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
18617 C...is as if first resonance is W+ and second W-.
18618
18619       SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
18620
18621 C...Double precision and integer declarations.
18622       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18623       IMPLICIT INTEGER(I-N)
18624       INTEGER PYK,PYCHGE,PYCOMP
18625 C...Parameter value; number of points in MC integration.
18626       PARAMETER (NPT=100)
18627 C...Commonblocks.
18628       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18629       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18630       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18631       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18632       COMMON/PYINT1/MINT(400),VINT(400)
18633       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
18634 C...Local arrays.
18635       DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
18636      &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
18637      &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
18638      &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
18639      &TMC(20),IJOIN(100)
18640
18641 C...Functions to give four-product and to do determinants.
18642       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)
18643       DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
18644      &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
18645      &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
18646
18647 C...Only allow fraction of recoupling for GH, intermediate and
18648 C...instantaneous.
18649       IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
18650         IF(PYR(0).GT.PARP(120)) RETURN
18651       ENDIF
18652       ISUB=MINT(1)
18653
18654 C...Common part for scenarios I, II, II', and GH.
18655       IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
18656      &MSTP(115).EQ.5) THEN
18657
18658 C...Read out frequently-used parameters.
18659         PI=PARU(1)
18660         HBAR=PARU(3)
18661         PMW=PMAS(24,1)
18662         IF(ISUB.EQ.22) PMW=PMAS(23,1)
18663         PGW=PMAS(24,2)
18664         IF(ISUB.EQ.22) PGW=PMAS(23,2)
18665         TFRAG=PARP(115)
18666         RHAD=PARP(116)
18667         FACT=PARP(117)
18668         BLOWR=PARP(118)
18669         BLOWT=PARP(119)
18670
18671 C...Find range of decay products of the W's.
18672 C...Background: the W's are stored in IW1 and IW2.
18673 C...Their direct decay products in NSD1+1 through NSD1+4.
18674 C...Products after shower (if any) in NSD1+5 through NAFT1
18675 C...for first W and in NAFT1+1 through N for the second.
18676         IF(NAFT1.GT.NSD1+4) THEN
18677           NBEG(1)=NSD1+5
18678           NEND(1)=NAFT1
18679         ELSE
18680           NBEG(1)=NSD1+1
18681           NEND(1)=NSD1+2
18682         ENDIF
18683         IF(N.GT.NAFT1) THEN
18684           NBEG(2)=NAFT1+1
18685           NEND(2)=N
18686         ELSE
18687           NBEG(2)=NSD1+3
18688           NEND(2)=NSD1+4
18689         ENDIF
18690
18691 C...Rearrange parton shower products along strings.
18692         NOLD=N
18693         CALL PYPREP(NSD1+1)
18694
18695 C...Find partons pointing back to W+ and W-; store them with quark
18696 C...end of string first.
18697         NNP=0
18698         NNM=0
18699         ISGP=0
18700         ISGM=0
18701         DO 120 I=NOLD+1,N
18702           IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
18703           IF(IABS(K(I,2)).GE.22) GOTO 120
18704           IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
18705             IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
18706             NNP=NNP+1
18707             IF(ISGP.EQ.1) THEN
18708               INP(NNP)=I
18709             ELSE
18710               DO 100 I1=NNP,2,-1
18711                 INP(I1)=INP(I1-1)
18712   100         CONTINUE
18713               INP(1)=I
18714             ENDIF
18715             IF(K(I,1).EQ.1) ISGP=0
18716           ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
18717             IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
18718             NNM=NNM+1
18719             IF(ISGM.EQ.1) THEN
18720               INM(NNM)=I
18721             ELSE
18722               DO 110 I1=NNM,2,-1
18723                 INM(I1)=INM(I1-1)
18724   110         CONTINUE
18725               INM(1)=I
18726             ENDIF
18727             IF(K(I,1).EQ.1) ISGM=0
18728           ENDIF
18729   120   CONTINUE
18730
18731 C...Boost to W+W- rest frame (not strictly needed).
18732         DO 130 J=1,3
18733           BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
18734   130   CONTINUE
18735         CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18736         CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18737         CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18738
18739 C...Select decay vertices of W+ and W-.
18740         TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
18741      &  SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
18742         TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
18743      &  SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
18744         GTMAX=MAX(TP,TM)
18745         DO 140 J=1,3
18746           XP(J)=TP*P(IW1,J)/P(IW1,4)
18747           XM(J)=TM*P(IW2,J)/P(IW2,4)
18748   140   CONTINUE
18749
18750 C...Begin scenario I specifics.
18751         IF(MSTP(115).EQ.1) THEN
18752
18753 C...Reconstruct velocity and direction of W+ string pieces.
18754           DO 170 IIP=1,NNP-1
18755             IF(K(INP(IIP),2).LT.0) GOTO 170
18756             I1=INP(IIP)
18757             I2=INP(IIP+1)
18758             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18759             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18760             DO 150 J=1,3
18761               V1(J)=P(I1,J)/P1A
18762               V2(J)=P(I2,J)/P2A
18763               BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
18764               DIRP(IIP,J)=V1(J)-V2(J)
18765   150       CONTINUE
18766             BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
18767      &      BETP(IIP,3)**2)
18768             DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
18769             DO 160 J=1,3
18770               DIRP(IIP,J)=DIRP(IIP,J)/DIRL
18771   160       CONTINUE
18772   170     CONTINUE
18773
18774 C...Reconstruct velocity and direction of W- string pieces.
18775           DO 200 IIM=1,NNM-1
18776             IF(K(INM(IIM),2).LT.0) GOTO 200
18777             I1=INM(IIM)
18778             I2=INM(IIM+1)
18779             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18780             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18781             DO 180 J=1,3
18782               V1(J)=P(I1,J)/P1A
18783               V2(J)=P(I2,J)/P2A
18784               BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
18785               DIRM(IIM,J)=V1(J)-V2(J)
18786   180       CONTINUE
18787             BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
18788      &      BETM(IIM,3)**2)
18789             DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
18790             DO 190 J=1,3
18791               DIRM(IIM,J)=DIRM(IIM,J)/DIRL
18792   190       CONTINUE
18793   200     CONTINUE
18794
18795 C...Loop over number of space-time points.
18796           NACC=0
18797           SUM=0D0
18798           DO 250 IPT=1,NPT
18799
18800 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
18801             R=SQRT(-LOG(PYR(0)))
18802             PHI=2D0*PI*PYR(0)
18803             X=BLOWR*RHAD*R*COS(PHI)
18804             Y=BLOWR*RHAD*R*SIN(PHI)
18805             R=SQRT(-LOG(PYR(0)))
18806             PHI=2D0*PI*PYR(0)
18807             Z=BLOWR*RHAD*R*COS(PHI)
18808             T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
18809
18810 C...Reject impossible points. Weight for sample distribution.
18811             IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
18812             WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
18813      &      EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
18814
18815 C...Loop over W+ string pieces and find one with largest weight.
18816             IMAXP=0
18817             WTMAXP=1D-10
18818             XD(1)=X-XP(1)
18819             XD(2)=Y-XP(2)
18820             XD(3)=Z-XP(3)
18821             XD(4)=T-TP
18822             DO 220 IIP=1,NNP-1
18823               IF(K(INP(IIP),2).LT.0) GOTO 220
18824               BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
18825               BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
18826               DO 210 J=1,3
18827                 XB(J)=XD(J)+BEDG*BETP(IIP,J)
18828   210         CONTINUE
18829               XB(4)=BETP(IIP,4)*(XD(4)-BED)
18830               SR2=XB(1)**2+XB(2)**2+XB(3)**2
18831               SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
18832      &        DIRP(IIP,3)*XB(3))**2
18833               WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18834      &        TFRAG**2)
18835               IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
18836               IF(WTP.GT.WTMAXP) THEN
18837                 IMAXP=IIP
18838                 WTMAXP=WTP
18839               ENDIF
18840   220       CONTINUE
18841
18842 C...Loop over W- string pieces and find one with largest weight.
18843             IMAXM=0
18844             WTMAXM=1D-10
18845             XD(1)=X-XM(1)
18846             XD(2)=Y-XM(2)
18847             XD(3)=Z-XM(3)
18848             XD(4)=T-TM
18849             DO 240 IIM=1,NNM-1
18850               IF(K(INM(IIM),2).LT.0) GOTO 240
18851               BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
18852               BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
18853               DO 230 J=1,3
18854                 XB(J)=XD(J)+BEDG*BETM(IIM,J)
18855   230         CONTINUE
18856               XB(4)=BETM(IIM,4)*(XD(4)-BED)
18857               SR2=XB(1)**2+XB(2)**2+XB(3)**2
18858               SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
18859      &        DIRM(IIM,3)*XB(3))**2
18860               WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18861      &        TFRAG**2)
18862               IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
18863               IF(WTM.GT.WTMAXM) THEN
18864                 IMAXM=IIM
18865                 WTMAXM=WTM
18866               ENDIF
18867   240       CONTINUE
18868
18869 C...Result of integration.
18870             WT=0D0
18871             IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
18872               WT=WTMAXP*WTMAXM/WTSMP
18873               SUM=SUM+WT
18874               NACC=NACC+1
18875               IAP(NACC)=IMAXP
18876               IAM(NACC)=IMAXM
18877               WTA(NACC)=WT
18878             ENDIF
18879   250     CONTINUE
18880           RES=BLOWR**3*BLOWT*SUM/NPT
18881
18882 C...Decide whether to reconnect and, if so, where.
18883           IACC=0
18884           PREC=1D0-EXP(-FACT*RES)
18885           IF(PREC.GT.PYR(0)) THEN
18886             RSUM=PYR(0)*SUM
18887             DO 260 IA=1,NACC
18888               IACC=IA
18889               RSUM=RSUM-WTA(IA)
18890               IF(RSUM.LE.0D0) GOTO 270
18891   260       CONTINUE
18892   270       IIP=IAP(IACC)
18893             IIM=IAM(IACC)
18894           ENDIF
18895
18896 C...Begin scenario II and II' specifics.
18897         ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
18898
18899 C...Loop through all string pieces, one from W+ and one from W-.
18900           NCROSS=0
18901           TC(0)=0D0
18902           DO 340 IIP=1,NNP-1
18903             IF(K(INP(IIP),2).LT.0) GOTO 340
18904             I1P=INP(IIP)
18905             I2P=INP(IIP+1)
18906             DO 330 IIM=1,NNM-1
18907               IF(K(INM(IIM),2).LT.0) GOTO 330
18908               I1M=INM(IIM)
18909               I2M=INM(IIM+1)
18910
18911 C...Find endpoint velocity vectors.
18912               DO 280 J=1,3
18913                 V1P(J)=P(I1P,J)/P(I1P,4)
18914                 V2P(J)=P(I2P,J)/P(I2P,4)
18915                 V1M(J)=P(I1M,J)/P(I1M,4)
18916                 V2M(J)=P(I2M,J)/P(I2M,4)
18917   280         CONTINUE
18918
18919 C...Define q matrix and find t.
18920               DO 290 J=1,3
18921                 Q(1,J)=V2P(J)-V1P(J)
18922                 Q(2,J)=-(V2M(J)-V1M(J))
18923                 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
18924                 Q(4,J)=V1P(J)-V1M(J)
18925   290         CONTINUE
18926               T=-DETER(1,2,3)/DETER(1,2,4)
18927
18928 C...Find alpha and beta; i.e. coordinates of crossing point.
18929               S11=Q(1,1)*(T-TP)
18930               S12=Q(2,1)*(T-TM)
18931               S13=Q(3,1)+Q(4,1)*T
18932               S21=Q(1,2)*(T-TP)
18933               S22=Q(2,2)*(T-TM)
18934               S23=Q(3,2)+Q(4,2)*T
18935               DEN=S11*S22-S12*S21
18936               ALP=(S12*S23-S22*S13)/DEN
18937               BET=(S21*S13-S11*S23)/DEN
18938
18939 C...Check if solution acceptable.
18940               IANSW=1
18941               IF(T.LT.GTMAX) IANSW=0
18942               IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
18943               IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
18944
18945 C...Find point of crossing and check that not inconsistent.
18946               DO 300 J=1,3
18947                 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
18948                 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
18949   300         CONTINUE
18950               D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
18951      &        (XPP(3)-XMM(3))**2
18952               D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
18953               D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
18954               IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
18955
18956 C...Find string eigentimes at crossing.
18957               IF(IANSW.EQ.1) THEN
18958                 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
18959      &          (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
18960                 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
18961      &          (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
18962               ELSE
18963                 TAUP=0D0
18964                 TAUM=0D0
18965               ENDIF
18966
18967 C...Order crossings by time. End loop over crossings.
18968               IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
18969                 NCROSS=NCROSS+1
18970                 DO 310 I1=NCROSS,1,-1
18971                   IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
18972                     IPC(I1)=IIP
18973                     IMC(I1)=IIM
18974                     TC(I1)=T
18975                     TPC(I1)=TAUP
18976                     TMC(I1)=TAUM
18977                     GOTO 320
18978                   ELSE
18979                     IPC(I1)=IPC(I1-1)
18980                     IMC(I1)=IMC(I1-1)
18981                     TC(I1)=TC(I1-1)
18982                     TPC(I1)=TPC(I1-1)
18983                     TMC(I1)=TMC(I1-1)
18984                   ENDIF
18985   310           CONTINUE
18986   320           CONTINUE
18987               ENDIF
18988   330       CONTINUE
18989   340     CONTINUE
18990
18991 C...Loop over crossings; find first (if any) acceptable one.
18992           IACC=0
18993           IF(NCROSS.GE.1) THEN
18994             DO 350 IC=1,NCROSS
18995               PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
18996               IF(PNFRAG.GT.PYR(0)) THEN
18997 C...Scenario II: only compare with fragmentation time.
18998                 IF(MSTP(115).EQ.2) THEN
18999                   IACC=IC
19000                   IIP=IPC(IACC)
19001                   IIM=IMC(IACC)
19002                   GOTO 360
19003 C...Scenario II': also require that string length decreases.
19004                 ELSE
19005                   IIP=IPC(IC)
19006                   IIM=IMC(IC)
19007                   I1P=INP(IIP)
19008                   I2P=INP(IIP+1)
19009                   I1M=INM(IIM)
19010                   I2M=INM(IIM+1)
19011                   ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19012                   ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19013                   IF(ELNEW.LT.ELOLD) THEN
19014                     IACC=IC
19015                     IIP=IPC(IACC)
19016                     IIM=IMC(IACC)
19017                     GOTO 360
19018                   ENDIF
19019                 ENDIF
19020               ENDIF
19021   350       CONTINUE
19022   360       CONTINUE
19023           ENDIF
19024
19025 C...Begin scenario GH specifics.
19026         ELSEIF(MSTP(115).EQ.5) THEN
19027
19028 C...Loop through all string pieces, one from W+ and one from W-.
19029           IACC=0
19030           ELMIN=1D0
19031           DO 380 IIP=1,NNP-1
19032             IF(K(INP(IIP),2).LT.0) GOTO 380
19033             I1P=INP(IIP)
19034             I2P=INP(IIP+1)
19035             DO 370 IIM=1,NNM-1
19036               IF(K(INM(IIM),2).LT.0) GOTO 370
19037               I1M=INM(IIM)
19038               I2M=INM(IIM+1)
19039
19040 C...Look for largest decrease of (exponent of) Lambda measure.
19041               ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19042               ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19043               ELDIF=ELNEW/MAX(1D-10,ELOLD)
19044               IF(ELDIF.LT.ELMIN) THEN
19045                 IACC=IIP+IIM
19046                 ELMIN=ELDIF
19047                 IPC(1)=IIP
19048                 IMC(1)=IIM
19049               ENDIF
19050   370       CONTINUE
19051   380     CONTINUE
19052           IIP=IPC(1)
19053           IIM=IMC(1)
19054         ENDIF
19055
19056 C...Common for scenarios I, II, II' and GH: reconnect strings.
19057         IF(IACC.NE.0) THEN
19058           MINT(32)=1
19059           NJOIN=0
19060           DO 390 IS=1,NNP+NNM
19061             NJOIN=NJOIN+1
19062             IF(IS.LE.IIP) THEN
19063               I=INP(IS)
19064             ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19065               I=INM(IS-IIP+IIM)
19066             ELSEIF(IS.LE.IIP+NNM) THEN
19067               I=INM(IS-IIP-NNM+IIM)
19068             ELSE
19069               I=INP(IS-NNM)
19070             ENDIF
19071             IJOIN(NJOIN)=I
19072             IF(K(I,2).LT.0) THEN
19073               CALL PYJOIN(NJOIN,IJOIN)
19074               NJOIN=0
19075             ENDIF
19076   390     CONTINUE
19077
19078 C...Restore original event record if no reconnection.
19079         ELSE
19080           DO 400 I=NSD1+1,NOLD
19081             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19082               K(I,4)=MOD(K(I,4),MSTU(5)**2)
19083               K(I,5)=MOD(K(I,5),MSTU(5)**2)
19084             ENDIF
19085   400     CONTINUE
19086           DO 410 I=NOLD+1,N
19087             K(K(I,3),1)=3
19088   410     CONTINUE
19089           N=NOLD
19090         ENDIF
19091
19092 C...Boost back system.
19093         CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19094         CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19095         IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19096      &  BEWW(1),BEWW(2),BEWW(3))
19097
19098 C...Common part for intermediate and instantaneous scenarios.
19099       ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19100         MINT(32)=1
19101
19102 C...Remove old shower products and reset showering ones.
19103         N=NSD1+4
19104         DO 420 I=NSD1+1,NSD1+4
19105           K(I,1)=3
19106           K(I,4)=MOD(K(I,4),MSTU(5)**2)
19107           K(I,5)=MOD(K(I,5),MSTU(5)**2)
19108   420   CONTINUE
19109
19110 C...Identify quark-antiquark pairs.
19111         IQ1=NSD1+1
19112         IQ2=NSD1+2
19113         IQ3=NSD1+3
19114         IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19115         IQ4=2*NSD1+7-IQ3
19116
19117 C...Reconnect strings.
19118         IJOIN(1)=IQ1
19119         IJOIN(2)=IQ4
19120         CALL PYJOIN(2,IJOIN)
19121         IJOIN(1)=IQ3
19122         IJOIN(2)=IQ2
19123         CALL PYJOIN(2,IJOIN)
19124
19125 C...Do new parton showers in intermediate scenario.
19126         IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19127           MSTJ50=MSTJ(50)
19128           MSTJ(50)=0
19129           CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19130           CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19131           MSTJ(50)=MSTJ50
19132
19133 C...Do new parton showers in instantaneous scenario.
19134         ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19135           PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19136      &    (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19137           PPM=SQRT(MAX(0D0,PPM2))
19138           CALL PYSHOW(IQ1,IQ4,PPM)
19139           PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19140      &    (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19141           PPM=SQRT(MAX(0D0,PPM2))
19142           CALL PYSHOW(IQ3,IQ2,PPM)
19143         ENDIF
19144       ENDIF
19145
19146       RETURN
19147       END
19148
19149 C***********************************************************************
19150
19151 C...PYKLIM
19152 C...Checks generated variables against pre-set kinematical limits;
19153 C...also calculates limits on variables used in generation.
19154
19155       SUBROUTINE PYKLIM(ILIM)
19156
19157 C...Double precision and integer declarations.
19158       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19159       IMPLICIT INTEGER(I-N)
19160       INTEGER PYK,PYCHGE,PYCOMP
19161 C...Commonblocks.
19162       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19163       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19164       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19165       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19166       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19167       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19168       COMMON/PYINT1/MINT(400),VINT(400)
19169       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19170       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19171      &/PYINT1/,/PYINT2/
19172
19173 C...Common kinematical expressions.
19174       MINT(51)=0
19175       ISUB=MINT(1)
19176       ISTSB=ISET(ISUB)
19177       IF(ISUB.EQ.96) GOTO 100
19178       SQM3=VINT(63)
19179       SQM4=VINT(64)
19180       IF(ILIM.NE.0) THEN
19181         IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19182           CKIN09=MAX(CKIN(9),CKIN(13))
19183           CKIN10=MIN(CKIN(10),CKIN(14))
19184           CKIN11=MAX(CKIN(11),CKIN(15))
19185           CKIN12=MIN(CKIN(12),CKIN(16))
19186         ELSE
19187           CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19188           CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19189           CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19190           CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19191         ENDIF
19192       ENDIF
19193       IF(ILIM.NE.1) THEN
19194         TAU=VINT(21)
19195         RM3=SQM3/(TAU*VINT(2))
19196         RM4=SQM4/(TAU*VINT(2))
19197         BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19198       ENDIF
19199       PTHMIN=CKIN(3)
19200       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19201      &PTHMIN=MAX(CKIN(3),CKIN(5))
19202
19203       IF(ILIM.EQ.0) THEN
19204 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19205 C...pre-set kinematical limits.
19206         YST=VINT(22)
19207         CTH=VINT(23)
19208         TAUP=VINT(26)
19209         TAUE=TAU
19210         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19211         X1=SQRT(TAUE)*EXP(YST)
19212         X2=SQRT(TAUE)*EXP(-YST)
19213         XF=X1-X2
19214         IF(MINT(47).NE.1) THEN
19215           IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19216           IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19217           IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19218           IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19219         ENDIF
19220         IF(MINT(45).NE.1) THEN
19221           IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19222         ENDIF
19223         IF(MINT(46).NE.1) THEN
19224           IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19225         ENDIF
19226         IF(MINT(45).EQ.2) THEN
19227           IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19228         ENDIF
19229         IF(MINT(46).EQ.2) THEN
19230           IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19231         ENDIF
19232         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19233           PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19234           EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19235      &    MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19236           EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19237      &    MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19238           Y3=YST+0.5D0*LOG(EXPY3)
19239           Y4=YST+0.5D0*LOG(EXPY4)
19240           YLARGE=MAX(Y3,Y4)
19241           YSMALL=MIN(Y3,Y4)
19242           ETALAR=20D0
19243           ETASMA=-20D0
19244           STH=SQRT(MAX(0D0,1D0-CTH**2))
19245           EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19246      &    CTH)**2-4D0*RM3))
19247           EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19248      &    CTH)**2-4D0*RM4))
19249           IF(STH.GE.1D-10) THEN
19250             EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19251      &      (BE34*STH)
19252             EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19253      &      (BE34*STH)
19254             ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19255             ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19256             ETALAR=MAX(ETA3,ETA4)
19257             ETASMA=MIN(ETA3,ETA4)
19258           ENDIF
19259           CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19260           CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19261           CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19262           CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19263           SH=TAU*VINT(2)
19264           RPTS=4D0*VINT(71)**2/SH
19265           BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19266           RM34=MAX(1D-20,2D0*RM3*RM4)
19267           IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19268      &    RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19269           RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19270           THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19271           UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19272           IF(PTH.LT.PTHMIN) MINT(51)=1
19273           IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19274           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19275           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19276           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19277           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19278           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19279           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19280           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19281           IF(THA.LT.CKIN(35)) MINT(51)=1
19282           IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19283           IF(UHA.LT.CKIN(37)) MINT(51)=1
19284           IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19285         ENDIF
19286         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19287           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19288           IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19289         ENDIF
19290
19291 C...Additional cuts on W2 (approximately) in DIS.
19292         IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19293           XBJ=X2
19294           IF(IABS(MINT(12)).LT.20) XBJ=X1
19295           Q2BJ=THA
19296           W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19297           IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19298           IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19299         ENDIF
19300
19301       ELSEIF(ILIM.EQ.1) THEN
19302 C...Calculate limits on tau
19303 C...0) due to definition
19304         TAUMN0=0D0
19305         TAUMX0=1D0
19306 C...1) due to limits on subsystem mass
19307         TAUMN1=CKIN(1)**2/VINT(2)
19308         TAUMX1=1D0
19309         IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19310 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19311         TM3=SQRT(SQM3+PTHMIN**2)
19312         TM4=SQRT(SQM4+PTHMIN**2)
19313         YDCOSH=1D0
19314         IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19315         TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19316         TAUMX2=1D0
19317 C...3) due to limits on pT-hat and cos(theta-hat)
19318         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19319         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19320         TAUMN3=0D0
19321         IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19322      &  (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19323      &  SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19324         TAUMX3=1D0
19325         IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19326      &  (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19327      &  SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19328 C...4) due to limits on x1 and x2
19329         TAUMN4=CKIN(21)*CKIN(23)
19330         TAUMX4=CKIN(22)*CKIN(24)
19331 C...5) due to limits on xF
19332         TAUMN5=0D0
19333         TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19334 C...6) due to limits on that and uhat
19335         TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19336         TAUMX6=1D0
19337         IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19338      &  (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19339
19340 C...Net effect of all separate limits.
19341         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19342         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19343         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19344           VINT(11)=1D0-1D-9
19345           VINT(31)=1D0+1D-9
19346         ELSEIF(MINT(47).EQ.5) THEN
19347           VINT(31)=MIN(VINT(31),1D0-2D-10)
19348         ELSEIF(MINT(47).GE.6) THEN
19349           VINT(31)=MIN(VINT(31),1D0-1D-10)
19350         ENDIF
19351         IF(VINT(31).LE.VINT(11)) MINT(51)=1
19352
19353       ELSEIF(ILIM.EQ.2) THEN
19354 C...Calculate limits on y*
19355         TAUE=TAU
19356         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19357         TAURT=SQRT(TAUE)
19358 C...0) due to kinematics
19359         YSTMN0=LOG(TAURT)
19360         YSTMX0=-YSTMN0
19361 C...1) due to explicit limits
19362         YSTMN1=CKIN(7)
19363         YSTMX1=CKIN(8)
19364 C...2) due to limits on x1
19365         YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19366         YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19367 C...3) due to limits on x2
19368         YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19369         YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19370 C...4) due to limits on xF
19371         YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19372         YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19373         YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19374         YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19375 C...5) due to simultaneous limits on y-large and y-small
19376         YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19377         YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19378         YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19379         YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19380         YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19381         YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19382 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19383 C...   y-small
19384         CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19385         RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19386         RZMX=BE34*MIN(CKIN(28),CTHLIM)
19387         YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19388         YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19389         YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19390         YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19391         YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19392         YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19393
19394 C...Net effect of all separate limits.
19395         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19396         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19397         IF(MINT(47).EQ.1) THEN
19398           VINT(12)=-1D-9
19399           VINT(32)=1D-9
19400         ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19401           VINT(12)=(1D0-1D-9)*YSTMX0
19402           VINT(32)=(1D0+1D-9)*YSTMX0
19403         ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19404           VINT(12)=-(1D0+1D-9)*YSTMX0
19405           VINT(32)=-(1D0-1D-9)*YSTMX0
19406         ELSEIF(MINT(47).EQ.5) THEN
19407           YSTEE=LOG((1D0-1D-10)/TAURT)
19408           VINT(12)=MAX(VINT(12),-YSTEE)
19409           VINT(32)=MIN(VINT(32),YSTEE)
19410         ENDIF
19411         IF(VINT(32).LE.VINT(12)) MINT(51)=1
19412
19413       ELSEIF(ILIM.EQ.3) THEN
19414 C...Calculate limits on cos(theta-hat)
19415         YST=VINT(22)
19416 C...0) due to definition
19417         CTNMN0=-1D0
19418         CTNMX0=0D0
19419         CTPMN0=0D0
19420         CTPMX0=1D0
19421 C...1) due to explicit limits
19422         CTNMN1=MIN(0D0,CKIN(27))
19423         CTNMX1=MIN(0D0,CKIN(28))
19424         CTPMN1=MAX(0D0,CKIN(27))
19425         CTPMX1=MAX(0D0,CKIN(28))
19426 C...2) due to limits on pT-hat
19427         CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19428         CTPMX2=-CTNMN2
19429         CTNMX2=0D0
19430         CTPMN2=0D0
19431         IF(CKIN(4).GE.0D0) THEN
19432           CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19433      &    (BE34**2*TAU*VINT(2))))
19434           CTPMN2=-CTNMX2
19435         ENDIF
19436 C...3) due to limits on y-large and y-small
19437         CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19438      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19439         CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19440      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19441         CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19442      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19443         CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19444      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19445 C...4) due to limits on that
19446         CTNMN4=-1D0
19447         CTNMX4=0D0
19448         CTPMN4=0D0
19449         CTPMX4=1D0
19450         SH=TAU*VINT(2)
19451         IF(CKIN(35).GT.0D0) THEN
19452           CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19453           IF(CTLIM.GT.0D0) THEN
19454             CTPMX4=CTLIM
19455           ELSE
19456             CTPMX4=0D0
19457             CTNMX4=CTLIM
19458           ENDIF
19459         ENDIF
19460         IF(CKIN(36).GT.0D0) THEN
19461           CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19462           IF(CTLIM.LT.0D0) THEN
19463             CTNMN4=CTLIM
19464           ELSE
19465             CTNMN4=0D0
19466             CTPMN4=CTLIM
19467           ENDIF
19468         ENDIF
19469 C...5) due to limits on uhat
19470         CTNMN5=-1D0
19471         CTNMX5=0D0
19472         CTPMN5=0D0
19473         CTPMX5=1D0
19474         IF(CKIN(37).GT.0D0) THEN
19475           CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19476           IF(CTLIM.LT.0D0) THEN
19477             CTNMN5=CTLIM
19478           ELSE
19479             CTNMN5=0D0
19480             CTPMN5=CTLIM
19481           ENDIF
19482         ENDIF
19483         IF(CKIN(38).GT.0D0) THEN
19484           CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19485           IF(CTLIM.GT.0D0) THEN
19486             CTPMX5=CTLIM
19487           ELSE
19488             CTPMX5=0D0
19489             CTNMX5=CTLIM
19490           ENDIF
19491         ENDIF
19492
19493 C...Net effect of all separate limits.
19494         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19495         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19496         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19497         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19498         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19499
19500       ELSEIF(ILIM.EQ.4) THEN
19501 C...Calculate limits on tau'
19502 C...0) due to kinematics
19503         TAPMN0=TAU
19504         IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19505           PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19506           TAPMN0=(SQRT(TAU)+PQRAT)**2
19507         ENDIF
19508         TAPMX0=1D0
19509 C...1) due to explicit limits
19510         TAPMN1=CKIN(31)**2/VINT(2)
19511         TAPMX1=1D0
19512         IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19513
19514 C...Net effect of all separate limits.
19515         VINT(16)=MAX(TAPMN0,TAPMN1)
19516         VINT(36)=MIN(TAPMX0,TAPMX1)
19517         IF(MINT(47).EQ.1) THEN
19518           VINT(16)=1D0-1D-9
19519           VINT(36)=1D0+1D-9
19520         ELSEIF(MINT(47).EQ.5) THEN
19521           VINT(36)=MIN(VINT(36),1D0-2D-10)
19522         ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19523           VINT(36)=MIN(VINT(36),1D0-1D-10)
19524         ENDIF
19525         IF(VINT(36).LE.VINT(16)) MINT(51)=1
19526
19527       ENDIF
19528       RETURN
19529
19530 C...Special case for low-pT and multiple interactions:
19531 C...effective kinematical limits for tau, y*, cos(theta-hat).
19532   100 IF(ILIM.EQ.0) THEN
19533       ELSEIF(ILIM.EQ.1) THEN
19534         IF(MSTP(82).LE.1) THEN
19535           VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19536      &    VINT(2)
19537         ELSE
19538           VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19539         ENDIF
19540         VINT(31)=1D0
19541       ELSEIF(ILIM.EQ.2) THEN
19542         VINT(12)=0.5D0*LOG(VINT(21))
19543         VINT(32)=-VINT(12)
19544       ELSEIF(ILIM.EQ.3) THEN
19545         IF(MSTP(82).LE.1) THEN
19546           ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19547      &    (VINT(21)*VINT(2))
19548         ELSE
19549           ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19550      &    (VINT(21)*VINT(2))
19551         ENDIF
19552         VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19553         VINT(33)=0D0
19554         VINT(14)=0D0
19555         VINT(34)=-VINT(13)
19556       ENDIF
19557
19558       RETURN
19559       END
19560
19561 C*********************************************************************
19562
19563 C...PYKMAP
19564 C...Maps a uniform distribution into a distribution of a kinematical
19565 C...variable according to one of the possibilities allowed. It is
19566 C...assumed that kinematical limits have been set by a PYKLIM call.
19567
19568       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19569
19570 C...Double precision and integer declarations.
19571       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19572       IMPLICIT INTEGER(I-N)
19573       INTEGER PYK,PYCHGE,PYCOMP
19574 C...Commonblocks.
19575       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19576       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19577       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19578       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19579       COMMON/PYINT1/MINT(400),VINT(400)
19580       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19581       SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19582
19583 C...Convert VVAR to tau variable.
19584       ISUB=MINT(1)
19585       ISTSB=ISET(ISUB)
19586       IF(IVAR.EQ.1) THEN
19587         TAUMIN=VINT(11)
19588         TAUMAX=VINT(31)
19589         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19590           TAURE=VINT(73)
19591           GAMRE=VINT(74)
19592         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19593           TAURE=VINT(75)
19594           GAMRE=VINT(76)
19595         ENDIF
19596         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19597           TAU=1D0
19598         ELSEIF(MVAR.EQ.1) THEN
19599           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19600         ELSEIF(MVAR.EQ.2) THEN
19601           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19602         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19603           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19604           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19605         ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19606           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
19607           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
19608           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
19609         ELSEIF(MINT(47).EQ.5) THEN
19610           AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
19611           ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
19612           TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19613         ELSE
19614           AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
19615           ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
19616           TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19617         ENDIF
19618         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
19619
19620 C...Convert VVAR to y* variable.
19621       ELSEIF(IVAR.EQ.2) THEN
19622         YSTMIN=VINT(12)
19623         YSTMAX=VINT(32)
19624         TAUE=VINT(21)
19625         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19626         IF(MINT(47).EQ.1) THEN
19627           YST=0D0
19628         ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19629           YST=-0.5D0*LOG(TAUE)
19630         ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19631           YST=0.5D0*LOG(TAUE)
19632         ELSEIF(MVAR.EQ.1) THEN
19633           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
19634         ELSEIF(MVAR.EQ.2) THEN
19635           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
19636         ELSEIF(MVAR.EQ.3) THEN
19637           AUPP=ATAN(EXP(YSTMAX))
19638           ALOW=ATAN(EXP(YSTMIN))
19639           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
19640         ELSEIF(MVAR.EQ.4) THEN
19641           YST0=-0.5D0*LOG(TAUE)
19642           AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
19643           ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
19644           YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
19645         ELSE
19646           YST0=-0.5D0*LOG(TAUE)
19647           AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
19648           ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
19649           YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
19650         ENDIF
19651         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
19652
19653 C...Convert VVAR to cos(theta-hat) variable.
19654       ELSEIF(IVAR.EQ.3) THEN
19655         RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
19656         RSQM=1D0+RM34
19657         IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19658      &  RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19659         CTNMIN=VINT(13)
19660         CTNMAX=VINT(33)
19661         CTPMIN=VINT(14)
19662         CTPMAX=VINT(34)
19663         IF(MVAR.EQ.1) THEN
19664           ANEG=CTNMAX-CTNMIN
19665           APOS=CTPMAX-CTPMIN
19666           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19667             VCTN=VVAR*(ANEG+APOS)/ANEG
19668             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
19669           ELSE
19670             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19671             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
19672           ENDIF
19673         ELSEIF(MVAR.EQ.2) THEN
19674           RMNMIN=MAX(RM34,RSQM-CTNMIN)
19675           RMNMAX=MAX(RM34,RSQM-CTNMAX)
19676           RMPMIN=MAX(RM34,RSQM-CTPMIN)
19677           RMPMAX=MAX(RM34,RSQM-CTPMAX)
19678           ANEG=LOG(RMNMIN/RMNMAX)
19679           APOS=LOG(RMPMIN/RMPMAX)
19680           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19681             VCTN=VVAR*(ANEG+APOS)/ANEG
19682             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
19683           ELSE
19684             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19685             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
19686           ENDIF
19687         ELSEIF(MVAR.EQ.3) THEN
19688           RMNMIN=MAX(RM34,RSQM+CTNMIN)
19689           RMNMAX=MAX(RM34,RSQM+CTNMAX)
19690           RMPMIN=MAX(RM34,RSQM+CTPMIN)
19691           RMPMAX=MAX(RM34,RSQM+CTPMAX)
19692           ANEG=LOG(RMNMAX/RMNMIN)
19693           APOS=LOG(RMPMAX/RMPMIN)
19694           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19695             VCTN=VVAR*(ANEG+APOS)/ANEG
19696             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
19697           ELSE
19698             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19699             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
19700           ENDIF
19701         ELSEIF(MVAR.EQ.4) THEN
19702           RMNMIN=MAX(RM34,RSQM-CTNMIN)
19703           RMNMAX=MAX(RM34,RSQM-CTNMAX)
19704           RMPMIN=MAX(RM34,RSQM-CTPMIN)
19705           RMPMAX=MAX(RM34,RSQM-CTPMAX)
19706           ANEG=1D0/RMNMAX-1D0/RMNMIN
19707           APOS=1D0/RMPMAX-1D0/RMPMIN
19708           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19709             VCTN=VVAR*(ANEG+APOS)/ANEG
19710             CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
19711           ELSE
19712             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19713             CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
19714           ENDIF
19715         ELSEIF(MVAR.EQ.5) THEN
19716           RMNMIN=MAX(RM34,RSQM+CTNMIN)
19717           RMNMAX=MAX(RM34,RSQM+CTNMAX)
19718           RMPMIN=MAX(RM34,RSQM+CTPMIN)
19719           RMPMAX=MAX(RM34,RSQM+CTPMAX)
19720           ANEG=1D0/RMNMIN-1D0/RMNMAX
19721           APOS=1D0/RMPMIN-1D0/RMPMAX
19722           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19723             VCTN=VVAR*(ANEG+APOS)/ANEG
19724             CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
19725           ELSE
19726             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19727             CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
19728           ENDIF
19729         ENDIF
19730         IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
19731         IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
19732         VINT(23)=CTH
19733
19734 C...Convert VVAR to tau' variable.
19735       ELSEIF(IVAR.EQ.4) THEN
19736         TAU=VINT(21)
19737         TAUPMN=VINT(16)
19738         TAUPMX=VINT(36)
19739         IF(MINT(47).EQ.1) THEN
19740           TAUP=1D0
19741         ELSEIF(MVAR.EQ.1) THEN
19742           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
19743         ELSEIF(MVAR.EQ.2) THEN
19744           AUPP=(1D0-TAU/TAUPMX)**4
19745           ALOW=(1D0-TAU/TAUPMN)**4
19746           TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
19747         ELSEIF(MINT(47).EQ.5) THEN
19748           AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
19749           ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
19750           TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19751         ELSE
19752           AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
19753           ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
19754           TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19755         ENDIF
19756         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
19757
19758 C...Selection of extra variables needed in 2 -> 3 process:
19759 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
19760 C...Since no options are available, the functions of PYKLIM
19761 C...and PYKMAP are joint for these choices.
19762       ELSEIF(IVAR.EQ.5) THEN
19763
19764 C...Read out total energy and particle masses.
19765         MINT(51)=0
19766         MPTPK=1
19767         IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
19768      &  .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
19769      &  MPTPK=2
19770         SHP=VINT(26)*VINT(2)
19771         SHPR=SQRT(SHP)
19772         PM1=VINT(201)
19773         PM2=VINT(206)
19774         PM3=SQRT(VINT(21))*VINT(1)
19775         IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
19776           MINT(51)=1
19777           RETURN
19778         ENDIF
19779         PMRS1=VINT(204)**2
19780         PMRS2=VINT(209)**2
19781
19782 C...Specify coefficients of pT choice; upper and lower limits.
19783         IF(MPTPK.EQ.1) THEN
19784           HWT1=0.4D0
19785           HWT2=0.4D0
19786         ELSE
19787           HWT1=0.05D0
19788           HWT2=0.05D0
19789         ENDIF
19790         HWT3=1D0-HWT1-HWT2
19791         PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
19792      &  (4D0*SHP)
19793         IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
19794         PTSMN1=CKIN(51)**2
19795         PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
19796      &  (4D0*SHP)
19797         IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
19798         PTSMN2=CKIN(53)**2
19799
19800 C...Select transverse momenta according to
19801 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
19802         HMX=PMRS1+PTSMX1
19803         HMN=PMRS1+PTSMN1
19804         IF(HMX.LT.1.0001D0*HMN) THEN
19805           MINT(51)=1
19806           RETURN
19807         ENDIF
19808         HDE=PTSMX1-PTSMN1
19809         RPT=PYR(0)
19810         IF(RPT.LT.HWT1) THEN
19811           PTS1=PTSMN1+PYR(0)*HDE
19812         ELSEIF(RPT.LT.HWT1+HWT2) THEN
19813           PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
19814         ELSE
19815           PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
19816         ENDIF
19817         WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
19818      &  HWT3*HMN*HMX/(PMRS1+PTS1)**2)
19819         HMX=PMRS2+PTSMX2
19820         HMN=PMRS2+PTSMN2
19821         IF(HMX.LT.1.0001D0*HMN) THEN
19822           MINT(51)=1
19823           RETURN
19824         ENDIF
19825         HDE=PTSMX2-PTSMN2
19826         RPT=PYR(0)
19827         IF(RPT.LT.HWT1) THEN
19828           PTS2=PTSMN2+PYR(0)*HDE
19829         ELSEIF(RPT.LT.HWT1+HWT2) THEN
19830           PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
19831         ELSE
19832           PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
19833         ENDIF
19834         WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
19835      &  HWT3*HMN*HMX/(PMRS2+PTS2)**2)
19836
19837 C...Select azimuthal angles and check pT choice.
19838         PHI1=PARU(2)*PYR(0)
19839         PHI2=PARU(2)*PYR(0)
19840         PHIR=PHI2-PHI1
19841         PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
19842         IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
19843      &  CKIN(56)**2)) THEN
19844           MINT(51)=1
19845           RETURN
19846         ENDIF
19847
19848 C...Calculate transverse masses and check phase space not closed.
19849         PMS1=PM1**2+PTS1
19850         PMS2=PM2**2+PTS2
19851         PMS3=PM3**2+PTS3
19852         PMT1=SQRT(PMS1)
19853         PMT2=SQRT(PMS2)
19854         PMT3=SQRT(PMS3)
19855         PM12=(PMT1+PMT2)**2
19856         IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
19857           MINT(51)=1
19858           RETURN
19859         ENDIF
19860
19861 C...Select rapidity for particle 3 and check phase space not closed.
19862         Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
19863      &  4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
19864         IF(Y3MAX.LT.1D-6) THEN
19865           MINT(51)=1
19866           RETURN
19867         ENDIF
19868         Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
19869         PZ3=PMT3*SINH(Y3)
19870         PE3=PMT3*COSH(Y3)
19871
19872 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
19873         PZ12=-PZ3
19874         PE12=SHPR-PE3
19875         PMS12=PE12**2-PZ12**2
19876         SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
19877         IF(SQL12.LT.1D-6*SHP) THEN
19878           MINT(51)=1
19879           RETURN
19880         ENDIF
19881         PMM1=PMS12+PMS1-PMS2
19882         PMM2=PMS12+PMS2-PMS1
19883         TFAC=-SHPR/(2D0*PMS12)
19884         T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
19885         T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
19886         T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
19887         T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
19888
19889 C...Construct relative mirror weights and make choice.
19890         IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
19891           WTPU=1D0
19892           WTNU=1D0
19893         ELSE
19894           WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
19895           WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
19896         ENDIF
19897         WTP=WTPU/(WTPU+WTNU)
19898         WTN=WTNU/(WTPU+WTNU)
19899         EPS=1D0
19900         IF(WTN.GT.PYR(0)) EPS=-1D0
19901
19902 C...Store result of variable choice and associated weights.
19903         VINT(202)=PTS1
19904         VINT(207)=PTS2
19905         VINT(203)=PHI1
19906         VINT(208)=PHI2
19907         VINT(205)=WTPTS1
19908         VINT(210)=WTPTS2
19909         VINT(211)=Y3
19910         VINT(212)=Y3MAX
19911         VINT(213)=EPS
19912         IF(EPS.GT.0D0) THEN
19913           VINT(214)=1D0/WTP
19914           VINT(215)=T1P
19915           VINT(216)=T2P
19916         ELSE
19917           VINT(214)=1D0/WTN
19918           VINT(215)=T1N
19919           VINT(216)=T2N
19920         ENDIF
19921         VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
19922         VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
19923         VINT(219)=0.5D0*(PMS12-PTS3)
19924         VINT(220)=SQL12
19925       ENDIF
19926
19927       RETURN
19928       END
19929
19930 C***********************************************************************
19931
19932 C...PYSIGH
19933 C...Differential matrix elements for all included subprocesses
19934 C...Note that what is coded is (disregarding the COMFAC factor)
19935 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
19936 C...when d(sigma-hat) is given in the zero-width limit, the delta
19937 C...function in tau is replaced by a (modified) Breit-Wigner:
19938 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
19939 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
19940 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
19941 C...i.e., dimensionless quantities
19942 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
19943 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
19944 C...(2pi)^4 delta^4(P - sum p_i)
19945 C...COMFAC contains the factor pi/s (or equivalent) and
19946 C...the conversion factor from GeV^-2 to mb
19947
19948       SUBROUTINE PYSIGH(NCHN,SIGS)
19949
19950 C...Double precision and integer declarations
19951       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19952       IMPLICIT INTEGER(I-N)
19953       INTEGER PYK,PYCHGE,PYCOMP
19954 C...Parameter statement to help give large particle numbers.
19955       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
19956      &KEXCIT=4000000,KDIMEN=5000000)
19957 C...Commonblocks
19958       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19959       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19960       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19961       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19962       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19963       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19964       COMMON/PYINT1/MINT(400),VINT(400)
19965       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19966       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19967       COMMON/PYINT4/MWID(500),WIDS(500,5)
19968       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19969       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19970       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
19971       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
19972      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
19973       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19974      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
19975      &/PYMSSM/,/PYSSMT/
19976 C...Local arrays and complex variables
19977       DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:300),
19978      &WDTE(0:300,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
19979       COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
19980       COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
19981      &COULCK,COULCP,COULCD,COULCR,COULCS
19982       REAL*8 A00L,A11L,A20L,COULXX
19983       COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
19984       COMPLEX*16 DAA,DZZ,DAZ
19985       COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU
19986       COMPLEX*16 DQQS,DQQT,DQQU,DQTS
19987       COMPLEX*16 DVVS,DVVT,DVVU
19988       COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
19989       COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
19990       COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
19991       INTEGER INDX(6)
19992
19993 C...Reset number of channels and cross-section
19994       NCHN=0
19995       SIGS=0D0
19996
19997 C...Convert H or A process into equivalent h one
19998       ISUB=MINT(1)
19999       ISUBSV=ISUB
20000       IHIGG=1
20001       KFHIGG=25
20002       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
20003      &ISUB.LE.190)) THEN
20004         IHIGG=2
20005         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
20006         KFHIGG=33+IHIGG
20007         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
20008         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
20009         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
20010         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
20011         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
20012         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
20013         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
20014         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
20015         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
20016         IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
20017         IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
20018         IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
20019       ENDIF
20020
20021 CMRENNA++
20022 C...Convert almost equivalent SUSY processes into each other
20023 C...Extract differences in flavours and couplings
20024       IF(ISUB.GE.200.AND.ISUB.LE.301) THEN
20025
20026 C...Sleptons and sneutrinos
20027         IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
20028           KFID=MOD(KFPR(ISUB,1),KSUSY1)
20029           ISUB=201
20030           ILR=0
20031         ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
20032           KFID=MOD(KFPR(ISUB,1),KSUSY1)
20033           ISUB=201
20034           ILR=1
20035         ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
20036           KFID=MOD(KFPR(ISUB,1),KSUSY1)
20037           ISUB=203
20038         ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
20039           IF(ISUB.EQ.210) THEN
20040             RKF=2.0D0
20041           ELSEIF(ISUB.EQ.211) THEN
20042             RKF=SFMIX(15,1)**2
20043           ELSEIF(ISUB.EQ.212) THEN
20044             RKF=SFMIX(15,2)**2
20045           ENDIF
20046           ISUB=210
20047         ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
20048           IF(ISUB.EQ.213) THEN
20049             KFID=MOD(KFPR(ISUB,1),KSUSY1)
20050             RKF=2.0D0
20051           ELSEIF(ISUB.EQ.214) THEN
20052             KFID=16
20053             RKF=1.0D0
20054           ENDIF
20055           ISUB=213
20056
20057 C...Neutralinos
20058         ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
20059           IF(ISUB.EQ.216) THEN
20060             IZID1=1
20061             IZID2=1
20062           ELSEIF(ISUB.EQ.217) THEN
20063             IZID1=2
20064             IZID2=2
20065           ELSEIF(ISUB.EQ.218) THEN
20066             IZID1=3
20067             IZID2=3
20068           ELSEIF(ISUB.EQ.219) THEN
20069             IZID1=4
20070             IZID2=4
20071           ELSEIF(ISUB.EQ.220) THEN
20072             IZID1=1
20073             IZID2=2
20074           ELSEIF(ISUB.EQ.221) THEN
20075             IZID1=1
20076             IZID2=3
20077           ELSEIF(ISUB.EQ.222) THEN
20078             IZID1=1
20079             IZID2=4
20080           ELSEIF(ISUB.EQ.223) THEN
20081             IZID1=2
20082             IZID2=3
20083           ELSEIF(ISUB.EQ.224) THEN
20084             IZID1=2
20085             IZID2=4
20086           ELSEIF(ISUB.EQ.225) THEN
20087             IZID1=3
20088             IZID2=4
20089           ENDIF
20090           ISUB=216
20091
20092 C...Charginos
20093         ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
20094           IF(ISUB.EQ.226) THEN
20095             IZID1=1
20096             IZID2=1
20097           ELSEIF(ISUB.EQ.227) THEN
20098             IZID1=2
20099             IZID2=2
20100           ELSEIF(ISUB.EQ.228) THEN
20101             IZID1=1
20102             IZID2=2
20103           ENDIF
20104           ISUB=226
20105
20106 C...Neutralino + chargino
20107         ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
20108           IF(ISUB.EQ.229) THEN
20109             IZID1=1
20110             IZID2=1
20111           ELSEIF(ISUB.EQ.230) THEN
20112             IZID1=1
20113             IZID2=2
20114           ELSEIF(ISUB.EQ.231) THEN
20115             IZID1=1
20116             IZID2=3
20117           ELSEIF(ISUB.EQ.232) THEN
20118             IZID1=1
20119             IZID2=4
20120           ELSEIF(ISUB.EQ.233) THEN
20121             IZID1=2
20122             IZID2=1
20123           ELSEIF(ISUB.EQ.234) THEN
20124             IZID1=2
20125             IZID2=2
20126           ELSEIF(ISUB.EQ.235) THEN
20127             IZID1=2
20128             IZID2=3
20129           ELSEIF(ISUB.EQ.236) THEN
20130             IZID1=2
20131             IZID2=4
20132           ENDIF
20133           ISUB=229
20134
20135 C...Gluino + neutralino
20136         ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
20137           IF(ISUB.EQ.237) THEN
20138             IZID=1
20139           ELSEIF(ISUB.EQ.238) THEN
20140             IZID=2
20141           ELSEIF(ISUB.EQ.239) THEN
20142             IZID=3
20143           ELSEIF(ISUB.EQ.240) THEN
20144             IZID=4
20145           ENDIF
20146           ISUB=237
20147
20148 C...Gluino + chargino
20149         ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
20150           IF(ISUB.EQ.241) THEN
20151             IZID=1
20152           ELSEIF(ISUB.EQ.242) THEN
20153             IZID=2
20154           ENDIF
20155           ISUB=241
20156
20157 C...Squark + neutralino
20158         ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
20159           ILR=0
20160           IF(MOD(ISUB,2).NE.0) ILR=1
20161           IF(ISUB.LE.247) THEN
20162             IZID=1
20163           ELSEIF(ISUB.LE.249) THEN
20164             IZID=2
20165           ELSEIF(ISUB.LE.251) THEN
20166             IZID=3
20167           ELSEIF(ISUB.LE.253) THEN
20168             IZID=4
20169           ENDIF
20170           ISUB=246
20171           RKF=5D0
20172
20173 C...Squark + chargino
20174         ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
20175           IF(ISUB.LE.255) THEN
20176             IZID=1
20177           ELSEIF(ISUB.LE.257) THEN
20178             IZID=2
20179           ENDIF
20180           IF(MOD(ISUB,2).EQ.0) THEN
20181             ILR=0
20182           ELSE
20183             ILR=1
20184           ENDIF
20185           ISUB=254
20186           RKF=5D0
20187
20188 C...Squark + gluino
20189         ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
20190           ISUB=258
20191           RKF=4D0
20192
20193 C...Stops
20194         ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
20195           ILR=0
20196           IF(ISUB.EQ.262) ILR=1
20197           ISUB=261
20198         ELSEIF(ISUB.EQ.265) THEN
20199           ISUB=264
20200
20201 C...Squarks
20202         ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
20203           ILR=0
20204           IF(ISUB.LE.273) THEN
20205             IF(ISUB.EQ.273) ILR=1
20206             ISUB=271
20207             RKF=16D0
20208           ELSEIF(ISUB.LE.276) THEN
20209             IF(ISUB.EQ.276) ILR=1
20210             ISUB=274
20211             RKF=16D0
20212           ELSEIF(ISUB.LE.278) THEN
20213             IF(ISUB.EQ.278) ILR=1
20214             ISUB=277
20215             RKF=4D0
20216           ELSE
20217             IF(ISUB.EQ.280) ILR=1
20218             ISUB=279
20219             RKF=4D0
20220           ENDIF
20221 C...Sbottoms
20222         ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
20223           ILR=0
20224           IF(ISUB.LE.283) THEN
20225             IF(ISUB.EQ.283) ILR=1
20226             ISUB=271
20227             RKF=4D0
20228           ELSEIF(ISUB.LE.286) THEN
20229             IF(ISUB.EQ.286) ILR=1
20230             ISUB=274
20231             RKF=4D0
20232           ELSEIF(ISUB.LE.288) THEN
20233             IF(ISUB.EQ.288) ILR=1
20234             ISUB=277
20235             RKF=1D0
20236           ELSEIF(ISUB.LE.290) THEN
20237             IF(ISUB.EQ.290) ILR=1
20238             ISUB=279
20239             RKF=1D0
20240           ELSEIF(ISUB.LE.293) THEN
20241             IF(ISUB.EQ.293) ILR=1
20242             ISUB=271
20243             RKF=1D0
20244           ELSEIF(ISUB.EQ.296) THEN
20245             ILR=1
20246             ISUB=274
20247             RKF=1D0
20248 C...Squark + gluino
20249           ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
20250             ISUB=258
20251             RKF=1D0
20252           ENDIF
20253 C...H+/- + H0
20254         ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
20255           IF(ISUB.EQ.297) THEN
20256             RKF=.5D0*PARU(195)**2
20257           ELSEIF(ISUB.EQ.298) THEN
20258             RKF=.5D0*(1D0-PARU(195)**2)
20259           ENDIF
20260           ISUB=210
20261 C...A0 + H0
20262         ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
20263           IF(ISUB.EQ.299) THEN
20264             RKF=PARU(186)**2
20265             KFID=25
20266           ELSEIF(ISUB.EQ.300) THEN
20267             RKF=PARU(187)**2
20268             KFID=35
20269           ENDIF
20270           ISUB=213
20271 C...H+ + H-
20272         ELSEIF(ISUB.EQ.301) THEN
20273           KFID=37
20274           RKF=1D0
20275           ISUB=201
20276         ENDIF
20277
20278 C...Convert almost equivalent technicolor processes into
20279 C...a few basic processes, and set distinguishing parameters.
20280       ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
20281         SQTV=PARP(137)**2
20282         SQTA=PARP(138)**2
20283         TANW=SQRT(PARU(102)/(1D0-PARU(102)))
20284         CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
20285         CSXI=COS(ASIN(PARP(141)))
20286         CSXIP=COS(ASIN(PARP(139)))
20287         QUPD=2D0*PARP(143)-1D0
20288 C... rho_tc0 -> W_L W_L
20289         IF(ISUB.EQ.361) THEN
20290            KFA=24
20291            KFB=24
20292            CAB2=PARP(141)**4
20293 C... rho_tc0 -> W_L pi_tc-
20294         ELSEIF(ISUB.EQ.362) THEN
20295            KFA=24
20296            KFB=KTECHN+211
20297            ISUB=361
20298            CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20299 C... pi_tc pi_tc
20300         ELSEIF(ISUB.EQ.363) THEN
20301            KFA=KTECHN+211
20302            KFB=KTECHN+211
20303            ISUB=361
20304            CAB2=(1D0-PARP(141)**2)**2
20305 C... rho_tc0/omega_tc -> gamma pi_tc
20306         ELSEIF(ISUB.EQ.364) THEN
20307            KFA=22
20308            KFB=KTECHN+111
20309            VOGP=CSXI
20310            VRGP=VOGP*QUPD
20311            AOGP=0D0
20312            ARGP=0D0
20313 C... gamma pi_tc'
20314         ELSEIF(ISUB.EQ.365) THEN
20315            KFA=22
20316            KFB=KTECHN+221
20317            ISUB=364
20318            VRGP=CSXIP
20319            VOGP=VRGP*QUPD
20320            AOGP=0D0
20321            ARGP=0D0
20322 C... Z pi_tc
20323         ELSEIF(ISUB.EQ.366) THEN
20324            KFA=23
20325            KFB=KTECHN+111
20326            ISUB=364
20327            VOGP=CSXI*CT2W
20328            VRGP=-QUPD*CSXI*TANW
20329            AOGP=0D0
20330            ARGP=0D0
20331 C... Z pi_tc'
20332         ELSEIF(ISUB.EQ.367) THEN
20333            KFA=23
20334            KFB=KTECHN+221
20335            ISUB=364
20336            VRGP=CSXIP*CT2W
20337            VOGP=-QUPD*CSXIP*TANW
20338            AOGP=0D0
20339            ARGP=0D0
20340 C... W_T pi_tc
20341         ELSEIF(ISUB.EQ.368) THEN
20342            KFA=24
20343            KFB=KTECHN+211
20344            ISUB=364
20345            VOGP=CSXI/(2D0*SQRT(PARU(102)))
20346            VRGP=0D0
20347            AOGP=0D0
20348            ARGP=-VOGP
20349 C... rho_tc+ -> W_L Z_L
20350         ELSEIF(ISUB.EQ.370) THEN
20351            KFA=24
20352            KFB=23
20353            CAB2=PARP(141)**4
20354 C... W_L pi_tc0
20355         ELSEIF(ISUB.EQ.371) THEN
20356            KFA=24
20357            KFB=KTECHN+111
20358            ISUB=370
20359            CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20360 C... Z_L pi_tc+
20361         ELSEIF(ISUB.EQ.372) THEN
20362            KFA=KTECHN+211
20363            KFB=23
20364            ISUB=370
20365            CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20366 C... pi_tc+ pi_tc0
20367         ELSEIF(ISUB.EQ.373) THEN
20368            KFA=KTECHN+211
20369            KFB=KTECHN+111
20370            ISUB=370
20371            CAB2=(1D0-PARP(141)**2)**2
20372 C... gamma pi_tc+
20373         ELSEIF(ISUB.EQ.374) THEN
20374            KFA=KTECHN+211
20375            KFB=22
20376            VRGP=QUPD*CSXI
20377            ARGP=0D0
20378 C... Z_T pi_tc+
20379         ELSEIF(ISUB.EQ.375) THEN
20380            KFA=KTECHN+211
20381            KFB=23
20382            ISUB=374
20383            VRGP=-QUPD*CSXI*TANW
20384            ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
20385 C... W_T pi_tc0
20386         ELSEIF(ISUB.EQ.376) THEN
20387            KFA=24
20388            KFB=KTECHN+111
20389            ISUB=374
20390            VRGP=0D0
20391            ARGP=-CSXI/(2D0*SQRT(PARU(102)))
20392 C... W_T pi_tc0'
20393         ELSEIF(ISUB.EQ.377) THEN
20394            KFA=24
20395            KFB=KTECHN+221
20396            ISUB=374
20397            ARGP=0D0
20398            VRGP=CSXIP/(2D0*SQRT(PARU(102)))
20399         ENDIF
20400       ENDIF
20401 CMRENNA--
20402
20403 C...Read kinematical variables and limits
20404       ISTSB=ISET(ISUBSV)
20405       TAUMIN=VINT(11)
20406       YSTMIN=VINT(12)
20407       CTNMIN=VINT(13)
20408       CTPMIN=VINT(14)
20409       TAUPMN=VINT(16)
20410       TAU=VINT(21)
20411       YST=VINT(22)
20412       CTH=VINT(23)
20413       XT2=VINT(25)
20414       TAUP=VINT(26)
20415       TAUMAX=VINT(31)
20416       YSTMAX=VINT(32)
20417       CTNMAX=VINT(33)
20418       CTPMAX=VINT(34)
20419       TAUPMX=VINT(36)
20420
20421 C...Derive kinematical quantities
20422       TAUE=TAU
20423       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20424       X(1)=SQRT(TAUE)*EXP(YST)
20425       X(2)=SQRT(TAUE)*EXP(-YST)
20426       IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20427         IF(X(1).GT.1D0-1D-7) RETURN
20428       ELSEIF(MINT(45).EQ.3) THEN
20429         X(1)=MIN(1D0-1.1D-10,X(1))
20430       ENDIF
20431       IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20432         IF(X(2).GT.1D0-1D-7) RETURN
20433       ELSEIF(MINT(46).EQ.3) THEN
20434         X(2)=MIN(1D0-1.1D-10,X(2))
20435       ENDIF
20436       SH=MAX(1D0,TAU*VINT(2))
20437       SQM3=VINT(63)
20438       SQM4=VINT(64)
20439       RM3=SQM3/SH
20440       RM4=SQM4/SH
20441       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20442       RPTS=4D0*VINT(71)**2/SH
20443       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20444       RM34=MAX(1D-20,2D0*RM3*RM4)
20445       RSQM=1D0+RM34
20446       IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20447      &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20448       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20449       IF(ISTSB.EQ.0) THEN
20450         TH=VINT(45)
20451         UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20452         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20453       ELSE
20454 C...Kinematics with incoming masses tricky: now depends on how
20455 C...subprocess has been set up w.r.t. order of incoming partons.
20456         RM1=0D0
20457         IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20458         RM2=0D0
20459         IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20460         IF(ISUB.EQ.35) THEN
20461           RM2=MIN(RM1,RM2)
20462           RM1=0D0
20463         ENDIF
20464         BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20465         TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20466         TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20467      &  BE12*BE34*CTH)
20468         UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20469      &  BE12*BE34*CTH)
20470         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20471       ENDIF
20472       SHR=SQRT(SH)
20473       SH2=SH**2
20474       TH2=TH**2
20475       UH2=UH**2
20476
20477 C...Choice of Q2 scale: hard, parton distributions, parton showers
20478       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20479         Q2=SH
20480       ELSEIF(ISTSB.EQ.8) THEN
20481         IF(MINT(107).EQ.4) Q2=VINT(307)
20482         IF(MINT(108).EQ.4) Q2=VINT(308)
20483       ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20484         Q2IN1=0D0
20485         IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20486         Q2IN2=0D0
20487         IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20488         IF(MSTP(32).EQ.1) THEN
20489           Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20490         ELSEIF(MSTP(32).EQ.2) THEN
20491           Q2=SQPTH+0.5D0*(SQM3+SQM4)
20492         ELSEIF(MSTP(32).EQ.3) THEN
20493           Q2=MIN(-TH,-UH)
20494         ELSEIF(MSTP(32).EQ.4) THEN
20495           Q2=SH
20496         ELSEIF(MSTP(32).EQ.5) THEN
20497           Q2=-TH
20498         ELSEIF(MSTP(32).EQ.6) THEN
20499           XSF1=X(1)
20500           IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20501           XSF2=X(2)
20502           IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20503           Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20504      &    (SQPTH+0.5D0*(SQM3+SQM4))
20505         ELSEIF(MSTP(32).EQ.7) THEN
20506           Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20507         ELSEIF(MSTP(32).EQ.8) THEN
20508           Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20509         ELSEIF(MSTP(32).EQ.9) THEN
20510           Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20511         ELSEIF(MSTP(32).EQ.10) THEN
20512           Q2=VINT(2)
20513         ENDIF
20514         IF(ISTSB.EQ.9) Q2=SQPTH
20515         IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20516      &  (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20517       ENDIF
20518       Q2SF=Q2
20519       IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20520         Q2SF=PMAS(23,1)**2
20521         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20522      &  ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20523         IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20524         IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
20525           Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20526           IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20527           IF(MSTP(39).EQ.3) Q2SF=SH
20528           IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20529           IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
20530         ENDIF
20531       ENDIF
20532       Q2PS=Q2SF
20533       Q2SF=Q2SF*PARP(34)
20534       IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20535       IF(MSTP(69).GE.2) Q2SF=VINT(2)
20536       IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20537      &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20538         XBJ=X(2)
20539         IF(MINT(43).EQ.3) XBJ=X(1)
20540         IF(MSTP(22).EQ.1) THEN
20541           Q2PS=-TH
20542         ELSEIF(MSTP(22).EQ.2) THEN
20543           Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20544         ELSEIF(MSTP(22).EQ.3) THEN
20545           Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20546         ELSE
20547           Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20548         ENDIF
20549       ENDIF
20550       IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20551      &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20552      &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20553         Q2PS=VINT(2)
20554       ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20555      &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20556      &ISUBSV.NE.68)) THEN
20557         Q2PS=VINT(2)
20558       ENDIF
20559
20560 C...Store derived kinematical quantities
20561       VINT(41)=X(1)
20562       VINT(42)=X(2)
20563       VINT(44)=SH
20564       VINT(43)=SQRT(SH)
20565       VINT(45)=TH
20566       VINT(46)=UH
20567       IF(ISTSB.NE.8) VINT(48)=SQPTH
20568       IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20569       VINT(50)=TAUP*VINT(2)
20570       VINT(49)=SQRT(MAX(0D0,VINT(50)))
20571       VINT(52)=Q2
20572       VINT(51)=SQRT(Q2)
20573       VINT(54)=Q2SF
20574       VINT(53)=SQRT(Q2SF)
20575       VINT(56)=Q2PS
20576       VINT(55)=SQRT(Q2PS)
20577
20578 C...Calculate parton distributions
20579       IF(ISTSB.LE.0) GOTO 160
20580       IF(MINT(47).GE.2) THEN
20581         DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20582           XSF=X(I)
20583           IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20584           IF(ISUB.EQ.99) THEN
20585             XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20586             Q2SF=VINT(309-I)
20587           ENDIF
20588           MINT(105)=MINT(102+I)
20589           MINT(109)=MINT(106+I)
20590           VINT(120)=VINT(2+I)
20591 C.... ALICE
20592 C.... Store side in MINT(124)
20593           MINT(124)=I
20594 C....
20595           IF(MSTP(57).LE.1) THEN
20596             CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20597           ELSE
20598             CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20599           ENDIF
20600           DO 100 KFL=-25,25
20601             XSFX(I,KFL)=XPQ(KFL)
20602   100     CONTINUE
20603   110   CONTINUE
20604       ENDIF
20605
20606 C...Calculate alpha_em, alpha_strong and K-factor
20607       XW=PARU(102)
20608       XWV=XW
20609       IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20610      &1D0-(PMAS(24,1)/PMAS(23,1))**2
20611       XW1=1D0-XW
20612       XWC=1D0/(16D0*XW*XW1)
20613       AEM=PYALEM(Q2)
20614       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20615       IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20616       FACK=1D0
20617       FACA=1D0
20618       IF(MSTP(33).EQ.1) THEN
20619         FACK=PARP(31)
20620       ELSEIF(MSTP(33).EQ.2) THEN
20621         FACK=PARP(31)
20622         FACA=PARP(32)/PARP(31)
20623       ELSEIF(MSTP(33).EQ.3) THEN
20624         Q2AS=PARP(33)*Q2
20625         IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20626      &  PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20627         AS=PYALPS(Q2AS)
20628       ENDIF
20629       VINT(138)=1D0
20630       VINT(57)=AEM
20631       VINT(58)=AS
20632
20633 C...Set flags for allowed reacting partons/leptons
20634       DO 140 I=1,2
20635         DO 120 J=-25,25
20636           KFAC(I,J)=0
20637   120   CONTINUE
20638         IF(MINT(44+I).EQ.1) THEN
20639           KFAC(I,MINT(10+I))=1
20640         ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20641           KFAC(I,MINT(10+I))=1
20642           KFAC(I,22)=1
20643           KFAC(I,24)=1
20644           KFAC(I,-24)=1
20645         ELSE
20646           DO 130 J=-25,25
20647             KFAC(I,J)=KFIN(I,J)
20648             IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20649             IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20650   130     CONTINUE
20651         ENDIF
20652   140 CONTINUE
20653
20654 C...Lower and upper limit for fermion flavour loops
20655       MMIN1=0
20656       MMAX1=0
20657       MMIN2=0
20658       MMAX2=0
20659       DO 150 J=-20,20
20660         IF(KFAC(1,-J).EQ.1) MMIN1=-J
20661         IF(KFAC(1,J).EQ.1) MMAX1=J
20662         IF(KFAC(2,-J).EQ.1) MMIN2=-J
20663         IF(KFAC(2,J).EQ.1) MMAX2=J
20664   150 CONTINUE
20665       MMINA=MIN(MMIN1,MMIN2)
20666       MMAXA=MAX(MMAX1,MMAX2)
20667
20668 C...Common resonance mass and width combinations
20669       SQMZ=PMAS(23,1)**2
20670       SQMW=PMAS(24,1)**2
20671       SQMH=PMAS(KFHIGG,1)**2
20672       GMMZ=PMAS(23,1)*PMAS(23,2)
20673       GMMW=PMAS(24,1)*PMAS(24,2)
20674       GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
20675 C...MRENNA+++
20676       ZWID=PMAS(23,2)
20677       WWID=PMAS(24,2)
20678       TANW=SQRT(XW/XW1)
20679       CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
20680 C...MRENNA---
20681 C...Polarization factors...implemented so far for W+W-(25)
20682       POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20683       POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20684       POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20685       POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20686
20687 C...Phase space integral in tau
20688       COMFAC=PARU(1)*PARU(5)/VINT(2)
20689       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20690       IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20691      &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20692         ATAU1=LOG(TAUMAX/TAUMIN)
20693         ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20694         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20695         IF(MINT(72).GE.1) THEN
20696           TAUR1=VINT(73)
20697           GAMR1=VINT(74)
20698           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20699           ATAU3=ATAUD/TAUR1
20700           IF(ATAUD.GT.1D-10) H1=H1+
20701      &    (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20702           ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20703           ATAU4=ATAUD/GAMR1
20704           IF(ATAUD.GT.1D-10) H1=H1+
20705      &    (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20706         ENDIF
20707         IF(MINT(72).EQ.2) THEN
20708           TAUR2=VINT(75)
20709           GAMR2=VINT(76)
20710           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20711           ATAU5=ATAUD/TAUR2
20712           IF(ATAUD.GT.1D-10) H1=H1+
20713      &    (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20714           ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20715           ATAU6=ATAUD/GAMR2
20716           IF(ATAUD.GT.1D-10) H1=H1+
20717      &    (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20718         ENDIF
20719         IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20720           ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20721           IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20722      &    MAX(2D-10,1D0-TAU)
20723         ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20724           ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20725           IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20726      &    MAX(1D-10,1D0-TAU)
20727         ENDIF
20728         COMFAC=COMFAC*ATAU1/(TAU*H1)
20729       ENDIF
20730
20731 C...Phase space integral in y*
20732       IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20733      &THEN
20734         AYST0=YSTMAX-YSTMIN
20735         IF(AYST0.LT.1D-10) THEN
20736           COMFAC=0D0
20737         ELSE
20738           AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20739           AYST2=AYST1
20740           AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20741           H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20742      &    (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20743      &    (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20744           IF(MINT(45).EQ.3) THEN
20745             YST0=-0.5D0*LOG(TAUE)
20746             AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20747      &      MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20748             IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20749      &      MAX(1D-10,1D0-EXP(YST-YST0))
20750           ENDIF
20751           IF(MINT(46).EQ.3) THEN
20752             YST0=-0.5D0*LOG(TAUE)
20753             AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20754      &      MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20755             IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20756      &      MAX(1D-10,1D0-EXP(-YST-YST0))
20757           ENDIF
20758           COMFAC=COMFAC*AYST0/H2
20759         ENDIF
20760       ENDIF
20761
20762 C...2 -> 1 processes: reduction in angular part of phase space integral
20763 C...for case of decaying resonance
20764       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20765       IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20766         IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20767           IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20768      &    KFPR(ISUB,1).EQ.39) THEN
20769             COMFAC=COMFAC*0.5D0*ACTH0
20770           ELSE
20771             COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20772      &      CTPMAX**3-CTPMIN**3)
20773           ENDIF
20774         ENDIF
20775
20776 C...2 -> 2 processes: angular part of phase space integral
20777       ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20778         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20779      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20780         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20781      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20782         ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20783      &  1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20784         ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20785      &  1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20786         H3=COEF(ISUBSV,13)+
20787      &  (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20788      &  (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20789      &  (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20790      &  (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20791         COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20792
20793 C...2 -> 2 processes: take into account final state Breit-Wigners
20794         COMFAC=COMFAC*VINT(80)
20795       ENDIF
20796
20797 C...2 -> 3, 4 processes: phace space integral in tau'
20798       IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20799         ATAUP1=LOG(TAUPMX/TAUPMN)
20800         ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20801         H4=COEF(ISUBSV,18)+
20802      &  (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20803         IF(MINT(47).EQ.5) THEN
20804           ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20805           H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20806         ELSEIF(MINT(47).GE.6) THEN
20807           ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20808           H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20809         ENDIF
20810         COMFAC=COMFAC*ATAUP1/H4
20811       ENDIF
20812
20813 C...2 -> 3, 4 processes: effective W/Z parton distributions
20814       IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20815         IF(1D0-TAU/TAUP.GT.1D-4) THEN
20816           FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20817         ELSE
20818           FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20819         ENDIF
20820         COMFAC=COMFAC*FZW
20821       ENDIF
20822
20823 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20824       IF(ISTSB.EQ.5) THEN
20825         COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20826      &  (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20827       ENDIF
20828
20829 C...Phase space integral for low-pT and multiple interactions
20830       IF(ISTSB.EQ.9) THEN
20831         COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20832         ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20833         ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20834         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20835         COMFAC=COMFAC*ATAU1/H1
20836         AYST0=YSTMAX-YSTMIN
20837         AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20838         AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20839         H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20840      &  (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20841      &  (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20842         COMFAC=COMFAC*AYST0/H2
20843         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20844 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20845 C...introduced to make cross-section finite for xT2 -> 0
20846         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20847      &  (1D0+VINT(149)))
20848       ENDIF
20849
20850 C...Real gamma + gamma: include factor 2 when different nature
20851   160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20852      &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20853
20854 C...Extra factors to include the effects of
20855 C...longitudinal resolved photons (but not direct or DIS ones).
20856       DO 170 ISDE=1,2
20857         IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20858      &  MINT(106+ISDE).LE.3) THEN
20859           VINT(314+ISDE)=1D0
20860           XY=PARP(166+ISDE)
20861           IF(MSTP(16).EQ.0) THEN
20862             IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20863      &      XY=VINT(304+ISDE)
20864           ELSE
20865             IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20866      &      XY=VINT(308+ISDE)
20867           ENDIF
20868           Q2GA=VINT(306+ISDE)
20869           IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20870      &    Q2GA.GT.0D0) THEN
20871             REDUCE=0D0
20872             IF(MSTP(17).EQ.1) THEN
20873               REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20874             ELSEIF(MSTP(17).EQ.2) THEN
20875               REDUCE=4D0*Q2GA/(Q2+Q2GA)
20876             ELSEIF(MSTP(17).EQ.3) THEN
20877               PMVIRT=PMAS(PYCOMP(113),1)
20878               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20879             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20880               PMVIRT=PMAS(PYCOMP(113),1)
20881               REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20882             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20883               PMVIRT=PMAS(PYCOMP(113),1)
20884               REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20885             ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20886               PMVSMN=4D0*PARP(15)**2
20887               PMVSMX=4D0*VINT(154)**2
20888               REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20889               REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20890      &        (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20891               REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20892             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20893               PMVIRT=PMAS(PYCOMP(113),1)
20894               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20895             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20896               PMVIRT=PMAS(PYCOMP(113),1)
20897               REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20898             ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20899               PMVSMN=4D0*PARP(15)**2
20900               PMVSMX=4D0*VINT(154)**2
20901               REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20902               REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20903               REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20904             ENDIF
20905             BEAMAS=PYMASS(11)
20906             IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20907             FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20908      &      (1D0-2D0*BEAMAS**2/Q2GA))
20909             VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20910           ENDIF
20911         ELSE
20912           VINT(314+ISDE)=1D0
20913         ENDIF
20914         COMFAC=COMFAC*VINT(314+ISDE)
20915   170 CONTINUE
20916
20917 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20918       IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
20919      &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
20920 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
20921         IF(MSTP(46).LE.4) THEN
20922           HDTLH=LOG(PMAS(25,1)/PARP(44))
20923           HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
20924           HDTNR=-1D0/18D0+HDTLH/6D0
20925         ELSE
20926           HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
20927           HDTLQ=LOG(PARP(45)/PARP(44))
20928           HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
20929           HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
20930         ENDIF
20931
20932 C...Calculate lowest and next-to-lowest order partial wave amplitudes
20933         HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
20934         A00L=DBLE(HDTV*SH)
20935         A20L=-0.5D0*A00L
20936         A11L=A00L/6D0
20937         HDTLS=LOG(SH/PARP(44)**2)
20938         A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20939      &  CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
20940      &  (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
20941         A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20942      &  CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
20943      &  (20D0/9D0)*HDTLS),DBLE(PARU(1)))
20944         A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
20945      &  CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
20946
20947 C...Unitarize partial wave amplitudes with Pade or K-matrix method
20948         IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
20949           A00U=A00L/(1D0-A004/A00L)
20950           A20U=A20L/(1D0-A204/A20L)
20951           A11U=A11L/(1D0-A114/A11L)
20952         ELSE
20953           A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
20954           A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
20955           A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
20956         ENDIF
20957       ENDIF
20958
20959 C...Supersymmetric processes - all of type 2 -> 2 :
20960 C...correct final-state Breit-Wigners from fixed to running width.
20961       IF(ISUB.GE.200.AND.ISUB.LE.301.AND.MSTP(42).GT.0) THEN
20962         DO 180 I=1,2
20963         KFLW=KFPR(ISUBSV,I)
20964         KCW=PYCOMP(KFLW)
20965         IF(PMAS(KCW,2).LT.PARP(41)) GOTO 180
20966         IF(I.EQ.1) SQMI=SQM3
20967         IF(I.EQ.2) SQMI=SQM4
20968         SQMS=PMAS(KCW,1)**2
20969         GMMS=PMAS(KCW,1)*PMAS(KCW,2)
20970         HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
20971         CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
20972         GMMI=SQRT(SQMI)*WDTP(0)
20973         HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
20974         COMFAC=COMFAC*(HBWI/HBWS)
20975   180   CONTINUE
20976       ENDIF
20977
20978 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
20979       IF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.
20980      $ISUB.EQ.68.OR.ISUB.EQ.81.OR.ISUB.EQ.82) THEN
20981         IF(MSTP(5).LE.4) THEN
20982           SQDQQS=1D0/SH2
20983           SQDQQT=1D0/TH2
20984           SQDQQU=1D0/UH2
20985           SQDGGS=SQDQQS
20986           SQDGGT=SQDQQT
20987           SQDGGU=SQDQQU
20988           REDGGS=1D0/SH
20989           REDGGT=1D0/TH
20990           REDGGU=1D0/UH
20991           REDGTU=1D0/UH/TH
20992           REDGSU=1D0/SH/UH
20993           REDGST=1D0/SH/TH
20994           REDQST=1D0/SH/TH
20995           REDQTU=1D0/UH/TH
20996           SQDLGS=0D0
20997           SQDLGT=0D0
20998           SQDQTS=SQDQQS
20999         ELSEIF(MSTP(5).EQ.5) THEN
21000           TANT3=ABS(PARP(155))
21001           IF(PARP(155).GT.0) THEN
21002             IMDL=1
21003           ELSE
21004             IMDL=2
21005           ENDIF
21006           ALPRHT=2.91D0*(3D0/PARP(144))
21007           SIN2T=2D0*TANT3/(TANT3**2+1D0)
21008           SINT3=TANT3/SQRT(TANT3**2+1D0)
21009           XIG=SQRT(PYALPS(SH)/ALPRHT)
21010           X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
21011      &        1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)/SIN2T
21012           X21=1D-3
21013           X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
21014      &    SINT3**2)*2D0/SIN2T
21015           X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
21016      &    SINT3**2)*2D0/SIN2T
21017           IF(PARP(156).GT.0.5D0) THEN
21018             SM1122=1D-6
21019             SM1112=1D-6
21020             SM1121=1D-6
21021             SM2212=1D-6
21022             SM2221=1D-6
21023             SM1221=1D-6
21024             X12=1D-6
21025             X21=1D-6
21026             X11=(1D0-SINT3**2)*2D0/SIN2T
21027             X22=-SINT3**2*2D0/SIN2T
21028           ELSE
21029             SM1122=100D0**2
21030             SM1112=150D0**2
21031             SM1121=150D0**2
21032             SM2212=150D0**2
21033             SM2221=75D0**2
21034             SM1221=50D0**2
21035           ENDIF
21036
21037 C.........SH LOOP
21038           ZTC(1,1)=DCMPLX(SH,0D0)
21039           CALL PYWIDT(3100021,SH,WDTP,WDTE)
21040           ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
21041           CALL PYWIDT(3100113,SH,WDTP,WDTE)
21042           ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
21043           CALL PYWIDT(3400113,SH,WDTP,WDTE)
21044           ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
21045           CALL PYWIDT(3200113,SH,WDTP,WDTE)
21046           ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
21047           CALL PYWIDT(3300113,SH,WDTP,WDTE)
21048           ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
21049           ZTC(1,2)=(0D0,0D0)
21050           ZTC(1,3)=DCMPLX(SH*XIG,0D0)
21051           ZTC(1,4)=ZTC(1,3)
21052           ZTC(1,5)=ZTC(1,2)
21053           ZTC(1,6)=ZTC(1,2)
21054           ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
21055           ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
21056           ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
21057           ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
21058           ZTC(3,4)=-SM1122
21059           ZTC(3,5)=-SM1112
21060           ZTC(3,6)=-SM1121
21061           ZTC(4,5)=-SM2212
21062           ZTC(4,6)=-SM2221
21063           ZTC(5,6)=-SM1221
21064
21065
21066           DO 200 I=1,5
21067             DO 190 J=I+1,6
21068                ZTC(J,I)=ZTC(I,J)
21069   190       CONTINUE
21070   200     CONTINUE
21071           CALL PYLDCM(ZTC,6,6,INDX,D)
21072           DO 220 I=1,6
21073             DO 210 J=1,6
21074               YTC(I,J)=(0D0,0D0)
21075               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21076   210       CONTINUE
21077   220     CONTINUE
21078
21079           DO 230 I=1,6
21080             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21081   230     CONTINUE
21082           DGGS=YTC(1,1)
21083           DVVS=YTC(2,2)
21084
21085           XIG=SQRT(PYALPS(-TH)/ALPRHT)
21086 C.........TH LOOP
21087           ZTC(1,1)=DCMPLX(TH)
21088           ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
21089           ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
21090           ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
21091           ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
21092           ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
21093           ZTC(1,2)=(0D0,0D0)
21094           ZTC(1,3)=DCMPLX(TH*XIG,0D0)
21095           ZTC(1,4)=ZTC(1,3)
21096           ZTC(1,5)=ZTC(1,2)
21097           ZTC(1,6)=ZTC(1,2)
21098           ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
21099           ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
21100           ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
21101           ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
21102           ZTC(3,4)=-SM1122
21103           ZTC(3,5)=-SM1112
21104           ZTC(3,6)=-SM1121
21105           ZTC(4,5)=-SM2212
21106           ZTC(4,6)=-SM2221
21107           ZTC(5,6)=-SM1221
21108           DO 250 I=1,5
21109             DO 240 J=I+1,6
21110                ZTC(J,I)=ZTC(I,J)
21111   240       CONTINUE
21112   250     CONTINUE
21113           CALL PYLDCM(ZTC,6,6,INDX,D)
21114           DO 270 I=1,6
21115             DO 260 J=1,6
21116               YTC(I,J)=(0D0,0D0)
21117               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21118   260       CONTINUE
21119   270     CONTINUE
21120           DO 280 I=1,6
21121             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21122   280     CONTINUE
21123           DGGT=YTC(1,1)
21124           DVVT=YTC(2,2)
21125
21126           XIG=SQRT(PYALPS(-UH)/ALPRHT)
21127 C.........UH LOOP
21128           ZTC(1,1)=DCMPLX(UH,0D0)
21129           ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
21130           ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
21131           ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
21132           ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
21133           ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
21134           ZTC(1,2)=(0D0,0D0)
21135           ZTC(1,3)=DCMPLX(UH*XIG,0D0)
21136           ZTC(1,4)=ZTC(1,3)
21137           ZTC(1,5)=ZTC(1,2)
21138           ZTC(1,6)=ZTC(1,2)
21139           ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
21140           ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
21141           ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
21142           ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
21143           ZTC(3,4)=-SM1122
21144           ZTC(3,5)=-SM1112
21145           ZTC(3,6)=-SM1121
21146           ZTC(4,5)=-SM2212
21147           ZTC(4,6)=-SM2221
21148           ZTC(5,6)=-SM1221
21149           DO 300 I=1,5
21150             DO 290 J=I+1,6
21151                ZTC(J,I)=ZTC(I,J)
21152   290       CONTINUE
21153   300     CONTINUE
21154           CALL PYLDCM(ZTC,6,6,INDX,D)
21155           DO 320 I=1,6
21156             DO 310 J=1,6
21157               YTC(I,J)=(0D0,0D0)
21158               IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21159   310       CONTINUE
21160   320     CONTINUE
21161           DO 330 I=1,6
21162             CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21163   330     CONTINUE
21164           DGGU=YTC(1,1)
21165           DVVU=YTC(2,2)
21166
21167           IF(IMDL.EQ.1) THEN
21168             DQQS=DGGS+DVVS*DCMPLX(TANT3**2)
21169             DQQT=DGGT+DVVT*DCMPLX(TANT3**2)
21170             DQQU=DGGU+DVVU*DCMPLX(TANT3**2)
21171             DQTS=DGGS-DVVS
21172           ELSE
21173             DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21174             DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)
21175             DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)
21176             DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21177           ENDIF
21178
21179           SQDQTS=ABS(DQTS)**2
21180           SQDQQS=ABS(DQQS)**2
21181           SQDQQT=ABS(DQQT)**2
21182           SQDQQU=ABS(DQQU)**2
21183           SQDLGS=ABS(DCMPLX(SH)*DGGS-DCMPLX(1D0))**2
21184           SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
21185
21186           SQDGGS=ABS(DGGS)**2
21187           SQDGGT=ABS(DGGT)**2
21188           SQDGGU=ABS(DGGU)**2
21189           REDGGS=DBLE(DGGS)
21190           REDGGT=DBLE(DGGT)
21191           REDGGU=DBLE(DGGU)
21192           REDGTU=DBLE(DGGU*DCONJG(DGGT))
21193           REDGSU=DBLE(DGGU*DCONJG(DGGS))
21194           REDGST=DBLE(DGGS*DCONJG(DGGT))
21195           REDQST=DBLE(DQQS*DCONJG(DQQT))
21196           REDQTU=DBLE(DQQT*DCONJG(DQQU))
21197         ENDIF
21198       ENDIF
21199
21200 C...A: 2 -> 1, tree diagrams
21201
21202       IF(ISUB.LE.10) THEN
21203         IF(ISUB.EQ.1) THEN
21204 C...f + fbar -> gamma*/Z0
21205           MINT(61)=2
21206           CALL PYWIDT(23,SH,WDTP,WDTE)
21207           HS=SHR*WDTP(0)
21208           FACZ=4D0*COMFAC*3D0
21209           HP0=AEM/3D0*SH
21210           HP1=AEM/3D0*XWC*SH
21211           DO 340 I=MMINA,MMAXA
21212             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 340
21213             EI=KCHG(IABS(I),1)/3D0
21214             AI=SIGN(1D0,EI)
21215             VI=AI-4D0*EI*XWV
21216             HI0=HP0
21217             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
21218             HI1=HP1
21219             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
21220             NCHN=NCHN+1
21221             ISIG(NCHN,1)=I
21222             ISIG(NCHN,2)=-I
21223             ISIG(NCHN,3)=1
21224             SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
21225      &      EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
21226      &      (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
21227      &      ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
21228   340     CONTINUE
21229
21230         ELSEIF(ISUB.EQ.2) THEN
21231 C...f + fbar' -> W+/-
21232           CALL PYWIDT(24,SH,WDTP,WDTE)
21233           HS=SHR*WDTP(0)
21234           FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
21235           HP=AEM/(24D0*XW)*SH
21236           DO 360 I=MMIN1,MMAX1
21237             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 360
21238             IA=IABS(I)
21239             DO 350 J=MMIN2,MMAX2
21240               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 350
21241               JA=IABS(J)
21242               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 350
21243               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21244      &        GOTO 350
21245               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21246               HI=HP*2D0
21247               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
21248               NCHN=NCHN+1
21249               ISIG(NCHN,1)=I
21250               ISIG(NCHN,2)=J
21251               ISIG(NCHN,3)=1
21252               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
21253               SIGH(NCHN)=HI*FACBW*HF
21254   350       CONTINUE
21255   360     CONTINUE
21256
21257         ELSEIF(ISUB.EQ.3) THEN
21258 C...f + fbar -> h0 (or H0, or A0)
21259           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21260           HS=SHR*WDTP(0)
21261           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21262           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21263      &    FACBW=0D0
21264           HP=AEM/(8D0*XW)*SH/SQMW*SH
21265           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21266           DO 370 I=MMINA,MMAXA
21267             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
21268             IA=IABS(I)
21269             RMQ=PYMRUN(IA,SH)**2/SH
21270             HI=HP*RMQ
21271             IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
21272             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
21273               IKFI=1
21274               IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
21275               IF(IA.GT.10) IKFI=3
21276               HI=HI*PARU(150+10*IHIGG+IKFI)**2
21277               IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
21278                 HI=HI/(1D0+RMSS(41))**2
21279                 IF(IHIGG.NE.3) THEN
21280                   HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
21281      &            PARU(151+10*IHIGG))**2
21282                 ENDIF
21283               ENDIF
21284             ENDIF
21285             NCHN=NCHN+1
21286             ISIG(NCHN,1)=I
21287             ISIG(NCHN,2)=-I
21288             ISIG(NCHN,3)=1
21289             SIGH(NCHN)=HI*FACBW*HF
21290   370     CONTINUE
21291
21292         ELSEIF(ISUB.EQ.4) THEN
21293 C...gamma + W+/- -> W+/-
21294
21295         ELSEIF(ISUB.EQ.5) THEN
21296 C...Z0 + Z0 -> h0
21297           CALL PYWIDT(25,SH,WDTP,WDTE)
21298           HS=SHR*WDTP(0)
21299           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21300           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21301           HP=AEM/(8D0*XW)*SH/SQMW*SH
21302           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21303           HI=HP/4D0
21304           FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
21305           DO 390 I=MMIN1,MMAX1
21306             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
21307             DO 380 J=MMIN2,MMAX2
21308               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
21309               EI=KCHG(IABS(I),1)/3D0
21310               AI=SIGN(1D0,EI)
21311               VI=AI-4D0*EI*XWV
21312               EJ=KCHG(IABS(J),1)/3D0
21313               AJ=SIGN(1D0,EJ)
21314               VJ=AJ-4D0*EJ*XWV
21315               NCHN=NCHN+1
21316               ISIG(NCHN,1)=I
21317               ISIG(NCHN,2)=J
21318               ISIG(NCHN,3)=1
21319               SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
21320   380       CONTINUE
21321   390     CONTINUE
21322
21323         ELSEIF(ISUB.EQ.6) THEN
21324 C...Z0 + W+/- -> W+/-
21325
21326         ELSEIF(ISUB.EQ.7) THEN
21327 C...W+ + W- -> Z0
21328
21329         ELSEIF(ISUB.EQ.8) THEN
21330 C...W+ + W- -> h0
21331           CALL PYWIDT(25,SH,WDTP,WDTE)
21332           HS=SHR*WDTP(0)
21333           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21334           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21335           HP=AEM/(8D0*XW)*SH/SQMW*SH
21336           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21337           HI=HP/2D0
21338           FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
21339           DO 410 I=MMIN1,MMAX1
21340             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
21341             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
21342             DO 400 J=MMIN2,MMAX2
21343               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
21344               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
21345               IF(EI*EJ.GT.0D0) GOTO 400
21346               NCHN=NCHN+1
21347               ISIG(NCHN,1)=I
21348               ISIG(NCHN,2)=J
21349               ISIG(NCHN,3)=1
21350               SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
21351   400       CONTINUE
21352   410     CONTINUE
21353
21354 C...B: 2 -> 2, tree diagrams
21355
21356         ELSEIF(ISUB.EQ.10) THEN
21357 C...f + f' -> f + f' (gamma/Z/W exchange)
21358           FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21359           FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21360           FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21361           FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21362           DO 430 I=MMIN1,MMAX1
21363             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 430
21364             IA=IABS(I)
21365             DO 420 J=MMIN2,MMAX2
21366               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 420
21367               JA=IABS(J)
21368 C...Electroweak couplings
21369               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21370               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21371               VI=AI-4D0*EI*XWV
21372               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21373               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21374               VJ=AJ-4D0*EJ*XWV
21375               EPSIJ=ISIGN(1,I*J)
21376 C...gamma/Z exchange, only gamma exchange, or only Z exchange
21377               IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21378                 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21379                   FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21380      &            (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21381      &            FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21382      &            4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21383                 ELSEIF(MSTP(21).EQ.2) THEN
21384                   FACNCF=FACGGF*EI**2*EJ**2
21385                 ELSE
21386                   FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21387      &            (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21388                 ENDIF
21389 C...Extrafactor 2 for only one incoming neutrino spin state.
21390                 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21391                 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21392                 NCHN=NCHN+1
21393                 ISIG(NCHN,1)=I
21394                 ISIG(NCHN,2)=J
21395                 ISIG(NCHN,3)=1
21396                 SIGH(NCHN)=FACNCF
21397               ENDIF
21398 C...W exchange
21399               IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21400                 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21401                 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21402                 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21403                 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21404                 NCHN=NCHN+1
21405                 ISIG(NCHN,1)=I
21406                 ISIG(NCHN,2)=J
21407                 ISIG(NCHN,3)=2
21408                 SIGH(NCHN)=FACCCF
21409               ENDIF
21410   420       CONTINUE
21411   430     CONTINUE
21412         ENDIF
21413
21414       ELSEIF(ISUB.LE.20) THEN
21415         IF(ISUB.EQ.11) THEN
21416 C...f + f' -> f + f' (g exchange)
21417           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
21418           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
21419      &    MSTP(34)*2D0/3D0*UH2*REDQST)
21420           FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
21421           FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21422           RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21423           IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21424 C...Modifications from contact interactions (compositeness)
21425             FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
21426             FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21427      &      (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
21428             FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21429      &      (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
21430             FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
21431             RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
21432           ELSEIF(MSTP(5).EQ.5) THEN
21433             FACCI1=FACQQ1
21434             FACCIB=FACQQB
21435             FACCI2=FACQQ2
21436             FACCI3=FACQQ1
21437             RATCII=1D0
21438           ENDIF
21439           DO 450 I=MMIN1,MMAX1
21440             IA=IABS(I)
21441             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
21442             DO 440 J=MMIN2,MMAX2
21443               JA=IABS(J)
21444               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
21445               NCHN=NCHN+1
21446               ISIG(NCHN,1)=I
21447               ISIG(NCHN,2)=J
21448               ISIG(NCHN,3)=1
21449               IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
21450      &        JA.GE.3))) THEN
21451                 SIGH(NCHN)=FACQQ1
21452                 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21453               ELSE
21454                 SIGH(NCHN)=FACCI1
21455                 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
21456                 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
21457               ENDIF
21458               IF(I.EQ.J) THEN
21459                 NCHN=NCHN+1
21460                 ISIG(NCHN,1)=I
21461                 ISIG(NCHN,2)=J
21462                 ISIG(NCHN,3)=2
21463                 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
21464                   SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
21465                   SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21466                 ELSE
21467                   SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
21468                   SIGH(NCHN)=0.5D0*FACCI2*RATCII
21469                 ENDIF
21470               ENDIF
21471   440       CONTINUE
21472   450     CONTINUE
21473
21474         ELSEIF(ISUB.EQ.12) THEN
21475 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21476           CALL PYWIDT(21,SH,WDTP,WDTE)
21477 C.........Do not use for b bbar in Standard TC2
21478           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)*SQDQQS*
21479      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21480           IF(MSTP(5).EQ.1) THEN
21481 C...Modifications from contact interactions (compositeness)
21482             FACCIB=FACQQB
21483             DO 460 I=1,2
21484               FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
21485      &        WDTE(I,2)+WDTE(I,4))
21486   460       CONTINUE
21487           ELSEIF(MSTP(5).GE.2.AND.MSTP(5).LE.4) THEN
21488             FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
21489      &      (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21490           ENDIF
21491           DO 470 I=MMINA,MMAXA
21492             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21493      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
21494             NCHN=NCHN+1
21495             ISIG(NCHN,1)=I
21496             ISIG(NCHN,2)=-I
21497             ISIG(NCHN,3)=1
21498             IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
21499               SIGH(NCHN)=FACQQB
21500             ELSE
21501               SIGH(NCHN)=FACCIB
21502             ENDIF
21503   470     CONTINUE
21504
21505         ELSEIF(ISUB.EQ.13) THEN
21506 C...f + fbar -> g + g (q + qbar -> g + g only)
21507           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21508      &    UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21509           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21510      &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21511           DO 480 I=MMINA,MMAXA
21512             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21513      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 480
21514             NCHN=NCHN+1
21515             ISIG(NCHN,1)=I
21516             ISIG(NCHN,2)=-I
21517             ISIG(NCHN,3)=1
21518             SIGH(NCHN)=0.5D0*FACGG1
21519             NCHN=NCHN+1
21520             ISIG(NCHN,1)=I
21521             ISIG(NCHN,2)=-I
21522             ISIG(NCHN,3)=2
21523             SIGH(NCHN)=0.5D0*FACGG2
21524   480     CONTINUE
21525
21526         ELSEIF(ISUB.EQ.14) THEN
21527 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21528           FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21529           DO 490 I=MMINA,MMAXA
21530             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21531      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
21532             EI=KCHG(IABS(I),1)/3D0
21533             NCHN=NCHN+1
21534             ISIG(NCHN,1)=I
21535             ISIG(NCHN,2)=-I
21536             ISIG(NCHN,3)=1
21537             SIGH(NCHN)=FACGG*EI**2
21538   490     CONTINUE
21539
21540         ELSEIF(ISUB.EQ.15) THEN
21541 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
21542           FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21543 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21544           HFGG=0D0
21545           HFGZ=0D0
21546           HFZZ=0D0
21547           RADC4=1D0+PYALPS(SQM4)/PARU(1)
21548           DO 500 I=1,MIN(16,MDCY(23,3))
21549             IDC=I+MDCY(23,2)-1
21550             IF(MDME(IDC,1).LT.0) GOTO 500
21551             IMDM=0
21552             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21553      &      IMDM=1
21554             IF(I.LE.8) THEN
21555               EF=KCHG(I,1)/3D0
21556               AF=SIGN(1D0,EF+0.1D0)
21557               VF=AF-4D0*EF*XWV
21558             ELSEIF(I.LE.16) THEN
21559               EF=KCHG(I+2,1)/3D0
21560               AF=SIGN(1D0,EF+0.1D0)
21561               VF=AF-4D0*EF*XWV
21562             ENDIF
21563             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21564             IF(4D0*RM1.LT.1D0) THEN
21565               FCOF=1D0
21566               IF(I.LE.8) FCOF=3D0*RADC4
21567               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21568               IF(IMDM.EQ.1) THEN
21569                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21570                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21571                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21572      &          AF**2*(1D0-4D0*RM1))*BE34
21573               ENDIF
21574             ENDIF
21575   500     CONTINUE
21576 C...Propagators: as simulated in PYOFSH and as desired
21577           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21578           MINT15=MINT(15)
21579           MINT(15)=1
21580           MINT(61)=1
21581           CALL PYWIDT(23,SQM4,WDTP,WDTE)
21582           MINT(15)=MINT15
21583           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21584           HFGG=HFGG*HFAEM*VINT(111)/SQM4
21585           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21586           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21587 C...Loop over flavours; consider full gamma/Z structure
21588           DO 510 I=MMINA,MMAXA
21589             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21590      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 510
21591             EI=KCHG(IABS(I),1)/3D0
21592             AI=SIGN(1D0,EI)
21593             VI=AI-4D0*EI*XWV
21594             NCHN=NCHN+1
21595             ISIG(NCHN,1)=I
21596             ISIG(NCHN,2)=-I
21597             ISIG(NCHN,3)=1
21598             SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
21599      &      (VI**2+AI**2)*HFZZ)/HBW4
21600   510     CONTINUE
21601
21602         ELSEIF(ISUB.EQ.16) THEN
21603 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
21604           FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21605 C...Propagators: as simulated in PYOFSH and as desired
21606           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21607           CALL PYWIDT(24,SQM4,WDTP,WDTE)
21608           GMMWC=SQRT(SQM4)*WDTP(0)
21609           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21610           FACWG=FACWG*HBW4C/HBW4
21611           DO 530 I=MMIN1,MMAX1
21612             IA=IABS(I)
21613             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 530
21614             DO 520 J=MMIN2,MMAX2
21615               JA=IABS(J)
21616               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 520
21617               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 520
21618               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21619               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21620               FCKM=VCKM((IA+1)/2,(JA+1)/2)
21621               NCHN=NCHN+1
21622               ISIG(NCHN,1)=I
21623               ISIG(NCHN,2)=J
21624               ISIG(NCHN,3)=1
21625               SIGH(NCHN)=FACWG*FCKM*WIDSC
21626   520       CONTINUE
21627   530     CONTINUE
21628
21629         ELSEIF(ISUB.EQ.17) THEN
21630 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21631
21632         ELSEIF(ISUB.EQ.18) THEN
21633 C...f + fbar -> gamma + gamma
21634           FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21635           DO 540 I=MMINA,MMAXA
21636             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
21637             EI=KCHG(IABS(I),1)/3D0
21638             FCOI=1D0
21639             IF(IABS(I).LE.10) FCOI=FACA/3D0
21640             NCHN=NCHN+1
21641             ISIG(NCHN,1)=I
21642             ISIG(NCHN,2)=-I
21643             ISIG(NCHN,3)=1
21644             SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21645   540     CONTINUE
21646
21647         ELSEIF(ISUB.EQ.19) THEN
21648 C...f + fbar -> gamma + (gamma*/Z0)
21649           FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21650 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21651           HFGG=0D0
21652           HFGZ=0D0
21653           HFZZ=0D0
21654           RADC4=1D0+PYALPS(SQM4)/PARU(1)
21655           DO 550 I=1,MIN(16,MDCY(23,3))
21656             IDC=I+MDCY(23,2)-1
21657             IF(MDME(IDC,1).LT.0) GOTO 550
21658             IMDM=0
21659             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21660      &      IMDM=1
21661             IF(I.LE.8) THEN
21662               EF=KCHG(I,1)/3D0
21663               AF=SIGN(1D0,EF+0.1D0)
21664               VF=AF-4D0*EF*XWV
21665             ELSEIF(I.LE.16) THEN
21666               EF=KCHG(I+2,1)/3D0
21667               AF=SIGN(1D0,EF+0.1D0)
21668               VF=AF-4D0*EF*XWV
21669             ENDIF
21670             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21671             IF(4D0*RM1.LT.1D0) THEN
21672               FCOF=1D0
21673               IF(I.LE.8) FCOF=3D0*RADC4
21674               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21675               IF(IMDM.EQ.1) THEN
21676                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21677                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21678                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21679      &          AF**2*(1D0-4D0*RM1))*BE34
21680               ENDIF
21681             ENDIF
21682   550     CONTINUE
21683 C...Propagators: as simulated in PYOFSH and as desired
21684           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21685           MINT15=MINT(15)
21686           MINT(15)=1
21687           MINT(61)=1
21688           CALL PYWIDT(23,SQM4,WDTP,WDTE)
21689           MINT(15)=MINT15
21690           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21691           HFGG=HFGG*HFAEM*VINT(111)/SQM4
21692           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21693           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21694 C...Loop over flavours; consider full gamma/Z structure
21695           DO 560 I=MMINA,MMAXA
21696             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 560
21697             EI=KCHG(IABS(I),1)/3D0
21698             AI=SIGN(1D0,EI)
21699             VI=AI-4D0*EI*XWV
21700             FCOI=1D0
21701             IF(IABS(I).LE.10) FCOI=FACA/3D0
21702             NCHN=NCHN+1
21703             ISIG(NCHN,1)=I
21704             ISIG(NCHN,2)=-I
21705             ISIG(NCHN,3)=1
21706             SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
21707      &      (VI**2+AI**2)*HFZZ)/HBW4
21708   560     CONTINUE
21709
21710         ELSEIF(ISUB.EQ.20) THEN
21711 C...f + fbar' -> gamma + W+/-
21712           FACGW=COMFAC*0.5D0*AEM**2/XW
21713 C...Propagators: as simulated in PYOFSH and as desired
21714           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21715           CALL PYWIDT(24,SQM4,WDTP,WDTE)
21716           GMMWC=SQRT(SQM4)*WDTP(0)
21717           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21718           FACGW=FACGW*HBW4C/HBW4
21719 C...Anomalous couplings
21720           TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21721           TERM2=0D0
21722           TERM3=0D0
21723           IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21724             TERM2=PARU(153)*(TH-UH)/(TH+UH)
21725             TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
21726      &      (4D0*SQMW))/(TH+UH)**2
21727           ENDIF
21728           DO 580 I=MMIN1,MMAX1
21729             IA=IABS(I)
21730             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 580
21731             DO 570 J=MMIN2,MMAX2
21732               JA=IABS(J)
21733               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 570
21734               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 570
21735               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21736      &        GOTO 570
21737               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21738               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21739               IF(IA.LE.10) THEN
21740                 FACWR=UH/(TH+UH)-1D0/3D0
21741                 FCKM=VCKM((IA+1)/2,(JA+1)/2)
21742                 FCOI=FACA/3D0
21743               ELSE
21744                 FACWR=-TH/(TH+UH)
21745                 FCKM=1D0
21746                 FCOI=1D0
21747               ENDIF
21748               FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
21749               NCHN=NCHN+1
21750               ISIG(NCHN,1)=I
21751               ISIG(NCHN,2)=J
21752               ISIG(NCHN,3)=1
21753               SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
21754   570       CONTINUE
21755   580     CONTINUE
21756         ENDIF
21757
21758       ELSEIF(ISUB.LE.30) THEN
21759         IF(ISUB.EQ.21) THEN
21760 C...f + fbar -> gamma + h0
21761
21762         ELSEIF(ISUB.EQ.22) THEN
21763 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
21764 C...Kinematics dependence
21765           FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
21766      &    SQM3*SQM4*(1D0/TH2+1D0/UH2))
21767 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21768           DO 600 I=1,6
21769             DO 590 J=1,3
21770               HGZ(I,J)=0D0
21771   590       CONTINUE
21772   600     CONTINUE
21773           RADC3=1D0+PYALPS(SQM3)/PARU(1)
21774           RADC4=1D0+PYALPS(SQM4)/PARU(1)
21775           DO 610 I=1,MIN(16,MDCY(23,3))
21776             IDC=I+MDCY(23,2)-1
21777             IF(MDME(IDC,1).LT.0) GOTO 610
21778             IMDM=0
21779             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
21780             IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
21781             IF(I.LE.8) THEN
21782               EF=KCHG(I,1)/3D0
21783               AF=SIGN(1D0,EF+0.1D0)
21784               VF=AF-4D0*EF*XWV
21785             ELSEIF(I.LE.16) THEN
21786               EF=KCHG(I+2,1)/3D0
21787               AF=SIGN(1D0,EF+0.1D0)
21788               VF=AF-4D0*EF*XWV
21789             ENDIF
21790             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
21791             IF(4D0*RM1.LT.1D0) THEN
21792               FCOF=1D0
21793               IF(I.LE.8) FCOF=3D0*RADC3
21794               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21795               IF(IMDM.GE.1) THEN
21796                 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21797                 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21798                 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21799      &          AF**2*(1D0-4D0*RM1))*BE34
21800               ENDIF
21801             ENDIF
21802             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21803             IF(4D0*RM1.LT.1D0) THEN
21804               FCOF=1D0
21805               IF(I.LE.8) FCOF=3D0*RADC4
21806               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21807               IF(IMDM.GE.1) THEN
21808                 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21809                 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21810                 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21811      &          AF**2*(1D0-4D0*RM1))*BE34
21812               ENDIF
21813             ENDIF
21814   610     CONTINUE
21815 C...Propagators: as simulated in PYOFSH and as desired
21816           HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
21817           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21818           MINT15=MINT(15)
21819           MINT(15)=1
21820           MINT(61)=1
21821           CALL PYWIDT(23,SQM3,WDTP,WDTE)
21822           MINT(15)=MINT15
21823           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21824           DO 620 J=1,3
21825             HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
21826             HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
21827             HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
21828   620     CONTINUE
21829           MINT15=MINT(15)
21830           MINT(15)=1
21831           MINT(61)=1
21832           CALL PYWIDT(23,SQM4,WDTP,WDTE)
21833           MINT(15)=MINT15
21834           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21835           DO 630 J=1,3
21836             HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
21837             HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
21838             HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
21839   630     CONTINUE
21840 C...Loop over flavours; separate left- and right-handed couplings
21841           DO 650 I=MMINA,MMAXA
21842             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 650
21843             EI=KCHG(IABS(I),1)/3D0
21844             AI=SIGN(1D0,EI)
21845             VI=AI-4D0*EI*XWV
21846             VALI=VI-AI
21847             VARI=VI+AI
21848             FCOI=1D0
21849             IF(IABS(I).LE.10) FCOI=FACA/3D0
21850             DO 640 J=1,3
21851               HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
21852               HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
21853               HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
21854               HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
21855   640       CONTINUE
21856             FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
21857      &      HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
21858      &      HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
21859      &      HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
21860             NCHN=NCHN+1
21861             ISIG(NCHN,1)=I
21862             ISIG(NCHN,2)=-I
21863             ISIG(NCHN,3)=1
21864             SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
21865   650     CONTINUE
21866
21867         ELSEIF(ISUB.EQ.23) THEN
21868 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
21869           FACZW=COMFAC*0.5D0*(AEM/XW)**2
21870           FACZW=FACZW*WIDS(23,2)
21871           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21872           FACBW=1D0/((SH-SQMW)**2+GMMW**2)
21873           DO 670 I=MMIN1,MMAX1
21874             IA=IABS(I)
21875             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 670
21876             DO 660 J=MMIN2,MMAX2
21877               JA=IABS(J)
21878               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 660
21879               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 660
21880               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21881      &        GOTO 660
21882               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21883               EI=KCHG(IA,1)/3D0
21884               AI=SIGN(1D0,EI+0.1D0)
21885               VI=AI-4D0*EI*XWV
21886               EJ=KCHG(JA,1)/3D0
21887               AJ=SIGN(1D0,EJ+0.1D0)
21888               VJ=AJ-4D0*EJ*XWV
21889               IF(VI+AI.GT.0) THEN
21890                 VISAV=VI
21891                 AISAV=AI
21892                 VI=VJ
21893                 AI=AJ
21894                 VJ=VISAV
21895                 AJ=AISAV
21896               ENDIF
21897               FCKM=1D0
21898               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
21899               FCOI=1D0
21900               IF(IA.LE.10) FCOI=FACA/3D0
21901               NCHN=NCHN+1
21902               ISIG(NCHN,1)=I
21903               ISIG(NCHN,2)=J
21904               ISIG(NCHN,3)=1
21905               SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
21906      &        (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
21907      &        (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
21908      &        THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
21909      &        SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
21910      &        WIDS(24,(5-KCHW)/2)
21911 C***Protect against slightly negative cross sections. (Reason yet to be
21912 C***sorted out. One possibility: addition of width to the W propagator.)
21913               SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
21914   660       CONTINUE
21915   670     CONTINUE
21916
21917         ELSEIF(ISUB.EQ.24) THEN
21918 C...f + fbar -> Z0 + h0 (or H0, or A0)
21919           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21920           FACHZ=COMFAC*8D0*(AEM*XWC)**2*
21921      &    (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
21922           FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
21923           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
21924      &    PARU(154+10*IHIGG)**2
21925           DO 680 I=MMINA,MMAXA
21926             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 680
21927             EI=KCHG(IABS(I),1)/3D0
21928             AI=SIGN(1D0,EI)
21929             VI=AI-4D0*EI*XWV
21930             FCOI=1D0
21931             IF(IABS(I).LE.10) FCOI=FACA/3D0
21932             NCHN=NCHN+1
21933             ISIG(NCHN,1)=I
21934             ISIG(NCHN,2)=-I
21935             ISIG(NCHN,3)=1
21936             SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
21937   680     CONTINUE
21938
21939         ELSEIF(ISUB.EQ.25) THEN
21940 C...f + fbar -> W+ + W-
21941 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
21942           GMMZC=GMMZ
21943           HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
21944           HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
21945           CALL PYWIDT(24,SQM3,WDTP,WDTE)
21946           GMMW3=SQRT(SQM3)*WDTP(0)
21947           HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
21948           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21949           CALL PYWIDT(24,SQM4,WDTP,WDTE)
21950           GMMW4=SQRT(SQM4)*WDTP(0)
21951           HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
21952 C...Kinematical functions
21953           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21954           THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
21955           GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
21956           GT=THUH34+4D0*THUH/TH2
21957           GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
21958           GU=THUH34+4D0*THUH/UH2
21959           GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
21960 C...Common factors and couplings
21961           FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
21962           FACWW=FACWW*WIDS(24,1)
21963           CGG=AEM**2/2D0
21964           CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
21965           CZZ=AEM**2/(32D0*XW**2)*HBWZC
21966           CNG=AEM**2/(4D0*XW)
21967           CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
21968           CNN=AEM**2/(16D0*XW**2)
21969 C...Coulomb factor for W+W- pair
21970           IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
21971             COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
21972             COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
21973             IF(COULE.LT.100D0*PMAS(24,2)) THEN
21974               COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21975      &        PMAS(24,2)**2)-COULE))
21976             ELSE
21977               COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
21978             ENDIF
21979             IF(COULE.GT.-100D0*PMAS(24,2)) THEN
21980               COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21981      &        PMAS(24,2)**2)+COULE))
21982             ELSE
21983               COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
21984      &        ABS(COULE)))
21985             ENDIF
21986             IF(MSTP(40).EQ.1) THEN
21987               COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
21988      &        MAX(1D-10,2D0*COULP*COULP1))
21989               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
21990             ELSEIF(MSTP(40).EQ.2) THEN
21991               COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
21992               COULCP=DCMPLX(0D0,DBLE(COULP))
21993               COULCD=(COULCK+COULCP)/(COULCK-COULCP)
21994               COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
21995      &        (4D0*COULCP)*LOG(COULCD)
21996               COULCS=DCMPLX(0D0,0D0)
21997               NSTP=100
21998               DO 690 ISTP=1,NSTP
21999                 COULXX=(ISTP-0.5)/NSTP
22000                 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22001      &          (1D0+COULXX/COULCD))
22002   690         CONTINUE
22003               COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22004      &        (COULCS/NSTP)
22005               FACCOU=ABS(COULCR)**2
22006             ELSEIF(MSTP(40).EQ.3) THEN
22007               COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22008      &        COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22009               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22010             ENDIF
22011           ELSEIF(MSTP(40).EQ.4) THEN
22012             FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22013           ELSE
22014             FACCOU=1D0
22015           ENDIF
22016           VINT(95)=FACCOU
22017           FACWW=FACWW*FACCOU
22018 C...Loop over allowed flavours
22019           DO 700 I=MMINA,MMAXA
22020             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 700
22021             EI=KCHG(IABS(I),1)/3D0
22022             AI=SIGN(1D0,EI+0.1D0)
22023             VI=AI-4D0*EI*XWV
22024             FCOI=1D0
22025             IF(IABS(I).LE.10) FCOI=FACA/3D0
22026             IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22027               IF(AI.LT.0D0) THEN
22028                 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22029      &          (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22030               ELSE
22031                 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22032      &          (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22033               ENDIF
22034             ELSE
22035               XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22036               BET=SQRT(1D0-4D0*XMW02/SH)
22037               GAT=1D0/SQRT(1D0-BET**2)
22038               STHE2=1D0-CTH**2
22039               AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22040               AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22041      &        2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22042               AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22043      &        2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22044      &        (1D0-2D0*BET*CTH+BET**2))
22045               PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22046               PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22047               A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22048               A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22049               A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22050               ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22051               ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22052               DSIGWW=ATOT
22053             ENDIF
22054             NCHN=NCHN+1
22055             ISIG(NCHN,1)=I
22056             ISIG(NCHN,2)=-I
22057             ISIG(NCHN,3)=1
22058             SIGH(NCHN)=FACWW*FCOI*DSIGWW
22059   700     CONTINUE
22060
22061         ELSEIF(ISUB.EQ.26) THEN
22062 C...f + fbar' -> W+/- + h0 (or H0, or A0)
22063           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22064           FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
22065      &    ((SH-SQMW)**2+GMMW**2)
22066           FACHW=FACHW*WIDS(KFHIGG,2)
22067           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
22068      &    PARU(155+10*IHIGG)**2
22069           DO 720 I=MMIN1,MMAX1
22070             IA=IABS(I)
22071             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 720
22072             DO 710 J=MMIN2,MMAX2
22073               JA=IABS(J)
22074               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 710
22075               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 710
22076               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22077      &        GOTO 710
22078               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22079               FCKM=1D0
22080               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22081               FCOI=1D0
22082               IF(IA.LE.10) FCOI=FACA/3D0
22083               NCHN=NCHN+1
22084               ISIG(NCHN,1)=I
22085               ISIG(NCHN,2)=J
22086               ISIG(NCHN,3)=1
22087               SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
22088   710       CONTINUE
22089   720     CONTINUE
22090
22091         ELSEIF(ISUB.EQ.27) THEN
22092 C...f + fbar -> h0 + h0
22093
22094         ELSEIF(ISUB.EQ.28) THEN
22095 C...f + g -> f + g (q + g -> q + g only)
22096           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
22097      &    UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
22098           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
22099      &    SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
22100           DO 740 I=MMINA,MMAXA
22101             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 740
22102             DO 730 ISDE=1,2
22103               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 730
22104               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 730
22105               NCHN=NCHN+1
22106               ISIG(NCHN,ISDE)=I
22107               ISIG(NCHN,3-ISDE)=21
22108               ISIG(NCHN,3)=1
22109               SIGH(NCHN)=FACQG1
22110               NCHN=NCHN+1
22111               ISIG(NCHN,ISDE)=I
22112               ISIG(NCHN,3-ISDE)=21
22113               ISIG(NCHN,3)=2
22114               SIGH(NCHN)=FACQG2
22115   730       CONTINUE
22116   740     CONTINUE
22117
22118         ELSEIF(ISUB.EQ.29) THEN
22119 C...f + g -> f + gamma (q + g -> q + gamma only)
22120           FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
22121           DO 760 I=MMINA,MMAXA
22122             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 760
22123             EI=KCHG(IABS(I),1)/3D0
22124             FACGQ=FGQ*EI**2
22125             DO 750 ISDE=1,2
22126               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 750
22127               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 750
22128               NCHN=NCHN+1
22129               ISIG(NCHN,ISDE)=I
22130               ISIG(NCHN,3-ISDE)=21
22131               ISIG(NCHN,3)=1
22132               SIGH(NCHN)=FACGQ
22133   750       CONTINUE
22134   760     CONTINUE
22135
22136         ELSEIF(ISUB.EQ.30) THEN
22137 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22138           FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22139      &    (-SH*UH)
22140 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22141           HFGG=0D0
22142           HFGZ=0D0
22143           HFZZ=0D0
22144           RADC4=1D0+PYALPS(SQM4)/PARU(1)
22145           DO 770 I=1,MIN(16,MDCY(23,3))
22146             IDC=I+MDCY(23,2)-1
22147             IF(MDME(IDC,1).LT.0) GOTO 770
22148             IMDM=0
22149             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22150      &      IMDM=1
22151             IF(I.LE.8) THEN
22152               EF=KCHG(I,1)/3D0
22153               AF=SIGN(1D0,EF+0.1D0)
22154               VF=AF-4D0*EF*XWV
22155             ELSEIF(I.LE.16) THEN
22156               EF=KCHG(I+2,1)/3D0
22157               AF=SIGN(1D0,EF+0.1D0)
22158               VF=AF-4D0*EF*XWV
22159             ENDIF
22160             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22161             IF(4D0*RM1.LT.1D0) THEN
22162               FCOF=1D0
22163               IF(I.LE.8) FCOF=3D0*RADC4
22164               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22165               IF(IMDM.EQ.1) THEN
22166                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22167                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22168                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22169      &          AF**2*(1D0-4D0*RM1))*BE34
22170               ENDIF
22171             ENDIF
22172   770     CONTINUE
22173 C...Propagators: as simulated in PYOFSH and as desired
22174           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22175           MINT15=MINT(15)
22176           MINT(15)=1
22177           MINT(61)=1
22178           CALL PYWIDT(23,SQM4,WDTP,WDTE)
22179           MINT(15)=MINT15
22180           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22181           HFGG=HFGG*HFAEM*VINT(111)/SQM4
22182           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22183           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22184 C...Loop over flavours; consider full gamma/Z structure
22185           DO 790 I=MMINA,MMAXA
22186             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 790
22187             EI=KCHG(IABS(I),1)/3D0
22188             AI=SIGN(1D0,EI)
22189             VI=AI-4D0*EI*XWV
22190             FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22191      &      (VI**2+AI**2)*HFZZ)/HBW4
22192             DO 780 ISDE=1,2
22193               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 780
22194               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 780
22195               NCHN=NCHN+1
22196               ISIG(NCHN,ISDE)=I
22197               ISIG(NCHN,3-ISDE)=21
22198               ISIG(NCHN,3)=1
22199               SIGH(NCHN)=FACZQ
22200   780       CONTINUE
22201   790     CONTINUE
22202         ENDIF
22203
22204       ELSEIF(ISUB.LE.40) THEN
22205         IF(ISUB.EQ.31) THEN
22206 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22207           FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22208      &    (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22209 C...Propagators: as simulated in PYOFSH and as desired
22210           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22211           CALL PYWIDT(24,SQM4,WDTP,WDTE)
22212           GMMWC=SQRT(SQM4)*WDTP(0)
22213           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22214           FACWQ=FACWQ*HBW4C/HBW4
22215           DO 810 I=MMINA,MMAXA
22216             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 810
22217             IA=IABS(I)
22218             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22219             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22220             DO 800 ISDE=1,2
22221               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 800
22222               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 800
22223               NCHN=NCHN+1
22224               ISIG(NCHN,ISDE)=I
22225               ISIG(NCHN,3-ISDE)=21
22226               ISIG(NCHN,3)=1
22227               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22228   800       CONTINUE
22229   810     CONTINUE
22230
22231         ELSEIF(ISUB.EQ.32) THEN
22232 C...f + g -> f + h0 (q + g -> q + h0 only)
22233           SQMHC=PMAS(25,1)**2
22234           FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
22235           DO 830 I=MMINA,MMAXA
22236             IA=IABS(I)
22237             IF(IA.NE.5) GOTO 830
22238             SQML=PMAS(IA,1)**2
22239             IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
22240      &      (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
22241      &      LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
22242             IUA=IA+MOD(IA,2)
22243             SQMQ=SQML
22244             FACHCQ=FHCQ*SQML/SQMW*
22245      &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
22246      &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
22247      &      (SQMHC-SQMQ-SH)/SH)
22248             KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22249             DO 820 ISDE=1,2
22250               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 820
22251               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 820
22252               NCHN=NCHN+1
22253               ISIG(NCHN,ISDE)=I
22254               ISIG(NCHN,3-ISDE)=21
22255               ISIG(NCHN,3)=1
22256               SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
22257   820       CONTINUE
22258   830     CONTINUE
22259
22260         ELSEIF(ISUB.EQ.33) THEN
22261 C...f + gamma -> f + g (q + gamma -> q + g only)
22262           FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
22263           DO 850 I=MMINA,MMAXA
22264             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 850
22265             EI=KCHG(IABS(I),1)/3D0
22266             FACGQ=FGQ*EI**2
22267             DO 840 ISDE=1,2
22268               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 840
22269               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 840
22270               NCHN=NCHN+1
22271               ISIG(NCHN,ISDE)=I
22272               ISIG(NCHN,3-ISDE)=22
22273               ISIG(NCHN,3)=1
22274               SIGH(NCHN)=FACGQ
22275   840       CONTINUE
22276   850     CONTINUE
22277
22278         ELSEIF(ISUB.EQ.34) THEN
22279 C...f + gamma -> f + gamma
22280           FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
22281          DO 870 I=MMINA,MMAXA
22282             IF(I.EQ.0) GOTO 870
22283             EI=KCHG(IABS(I),1)/3D0
22284             FACGQ=FGQ*EI**4
22285             DO 860 ISDE=1,2
22286               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 860
22287               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 860
22288               NCHN=NCHN+1
22289               ISIG(NCHN,ISDE)=I
22290               ISIG(NCHN,3-ISDE)=22
22291               ISIG(NCHN,3)=1
22292               SIGH(NCHN)=FACGQ
22293   860       CONTINUE
22294   870     CONTINUE
22295
22296         ELSEIF(ISUB.EQ.35) THEN
22297 C...f + gamma -> f + (gamma*/Z0)
22298           IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22299             FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22300             FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22301           ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22302             FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22303             FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22304           ELSE
22305             FZQN=SH2+UH2+2D0*SQM4*TH
22306             FZQDTM=-SH*UH
22307           ENDIF
22308           FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22309 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22310           HFGG=0D0
22311           HFGZ=0D0
22312           HFZZ=0D0
22313           RADC4=1D0+PYALPS(SQM4)/PARU(1)
22314           DO 880 I=1,MIN(16,MDCY(23,3))
22315             IDC=I+MDCY(23,2)-1
22316             IF(MDME(IDC,1).LT.0) GOTO 880
22317             IMDM=0
22318             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22319      &      IMDM=1
22320             IF(I.LE.8) THEN
22321               EF=KCHG(I,1)/3D0
22322               AF=SIGN(1D0,EF+0.1D0)
22323               VF=AF-4D0*EF*XWV
22324             ELSEIF(I.LE.16) THEN
22325               EF=KCHG(I+2,1)/3D0
22326               AF=SIGN(1D0,EF+0.1D0)
22327               VF=AF-4D0*EF*XWV
22328             ENDIF
22329             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22330             IF(4D0*RM1.LT.1D0) THEN
22331               FCOF=1D0
22332               IF(I.LE.8) FCOF=3D0*RADC4
22333               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22334               IF(IMDM.EQ.1) THEN
22335                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22336                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22337                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22338      &          AF**2*(1D0-4D0*RM1))*BE34
22339               ENDIF
22340             ENDIF
22341   880     CONTINUE
22342 C...Propagators: as simulated in PYOFSH and as desired
22343           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22344           MINT15=MINT(15)
22345           MINT(15)=1
22346           MINT(61)=1
22347           CALL PYWIDT(23,SQM4,WDTP,WDTE)
22348           MINT(15)=MINT15
22349           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22350           HFGG=HFGG*HFAEM*VINT(111)/SQM4
22351           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22352           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22353 C...Loop over flavours; consider full gamma/Z structure
22354           DO 900 I=MMINA,MMAXA
22355             IF(I.EQ.0) GOTO 900
22356             EI=KCHG(IABS(I),1)/3D0
22357             AI=SIGN(1D0,EI)
22358             VI=AI-4D0*EI*XWV
22359             FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22360      &      (VI**2+AI**2)*HFZZ)/HBW4
22361             FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22362             DO 890 ISDE=1,2
22363               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 890
22364               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 890
22365               NCHN=NCHN+1
22366               ISIG(NCHN,ISDE)=I
22367               ISIG(NCHN,3-ISDE)=22
22368               ISIG(NCHN,3)=1
22369               SIGH(NCHN)=FACZQ*FZQN/FZQD
22370   890       CONTINUE
22371   900     CONTINUE
22372
22373         ELSEIF(ISUB.EQ.36) THEN
22374 C...f + gamma -> f' + W+/-
22375           FWQ=COMFAC*AEM**2/(2D0*XW)*
22376      &    (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
22377 C...Propagators: as simulated in PYOFSH and as desired
22378           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22379           CALL PYWIDT(24,SQM4,WDTP,WDTE)
22380           GMMWC=SQRT(SQM4)*WDTP(0)
22381           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22382           FWQ=FWQ*HBW4C/HBW4
22383           DO 920 I=MMINA,MMAXA
22384             IF(I.EQ.0) GOTO 920
22385             IA=IABS(I)
22386             EIA=ABS(KCHG(IABS(I),1)/3D0)
22387             FACWQ=FWQ*(EIA-SH/(SH+UH))**2
22388             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22389             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22390             DO 910 ISDE=1,2
22391               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 910
22392               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 910
22393               NCHN=NCHN+1
22394               ISIG(NCHN,ISDE)=I
22395               ISIG(NCHN,3-ISDE)=22
22396               ISIG(NCHN,3)=1
22397               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22398   910       CONTINUE
22399   920     CONTINUE
22400
22401         ELSEIF(ISUB.EQ.37) THEN
22402 C...f + gamma -> f + h0
22403
22404         ELSEIF(ISUB.EQ.38) THEN
22405 C...f + Z0 -> f + g (q + Z0 -> q + g only)
22406
22407         ELSEIF(ISUB.EQ.39) THEN
22408 C...f + Z0 -> f + gamma
22409
22410         ELSEIF(ISUB.EQ.40) THEN
22411 C...f + Z0 -> f + Z0
22412         ENDIF
22413
22414       ELSEIF(ISUB.LE.50) THEN
22415         IF(ISUB.EQ.41) THEN
22416 C...f + Z0 -> f' + W+/-
22417
22418         ELSEIF(ISUB.EQ.42) THEN
22419 C...f + Z0 -> f + h0
22420
22421         ELSEIF(ISUB.EQ.43) THEN
22422 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
22423
22424         ELSEIF(ISUB.EQ.44) THEN
22425 C...f + W+/- -> f' + gamma
22426
22427         ELSEIF(ISUB.EQ.45) THEN
22428 C...f + W+/- -> f' + Z0
22429
22430         ELSEIF(ISUB.EQ.46) THEN
22431 C...f + W+/- -> f' + W+/-
22432
22433         ELSEIF(ISUB.EQ.47) THEN
22434 C...f + W+/- -> f' + h0
22435
22436         ELSEIF(ISUB.EQ.48) THEN
22437 C...f + h0 -> f + g (q + h0 -> q + g only)
22438
22439         ELSEIF(ISUB.EQ.49) THEN
22440 C...f + h0 -> f + gamma
22441
22442         ELSEIF(ISUB.EQ.50) THEN
22443 C...f + h0 -> f + Z0
22444         ENDIF
22445
22446       ELSEIF(ISUB.LE.60) THEN
22447         IF(ISUB.EQ.51) THEN
22448 C...f + h0 -> f' + W+/-
22449
22450         ELSEIF(ISUB.EQ.52) THEN
22451 C...f + h0 -> f + h0
22452
22453         ELSEIF(ISUB.EQ.53) THEN
22454 C...g + g -> f + fbar (g + g -> q + qbar only)
22455           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 940
22456           IDC0=MDCY(21,2)-1
22457 C...Begin by d, u, s flavours.
22458           FLAVWT=0D0
22459           IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
22460      &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
22461           IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
22462      &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
22463           IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
22464      &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
22465           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
22466      &    UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22467           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
22468      &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22469           NCHN=NCHN+1
22470           ISIG(NCHN,1)=21
22471           ISIG(NCHN,2)=21
22472           ISIG(NCHN,3)=1
22473           SIGH(NCHN)=FACQQ1
22474           NCHN=NCHN+1
22475           ISIG(NCHN,1)=21
22476           ISIG(NCHN,2)=21
22477           ISIG(NCHN,3)=2
22478           SIGH(NCHN)=FACQQ2
22479 C...Next c and b flavours: modified that and uhat for fixed
22480 C...cos(theta-hat).
22481           DO 930 IFL=4,5
22482           SQMAVG=PMAS(IFL,1)**2
22483           IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
22484             BE34=SQRT(1D0-4D0*SQMAVG/SH)
22485             THQ=-0.5D0*SH*(1D0-BE34*CTH)
22486             UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22487             THUHQ=THQ*UHQ-SQMAVG*SH
22488             IF(MSTP(34).EQ.0) THEN
22489               FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
22490               FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
22491             ELSE
22492               FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22493      &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
22494               FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22495      &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
22496             ENDIF
22497             IF(MSTP(5).GE.5) THEN
22498               FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
22499      &        2.25D0*THQ*UHQ/SH2*SQDLGS
22500               FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
22501      &        2.25D0*THQ*UHQ/SH2*SQDLGS
22502             ENDIF
22503             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
22504             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
22505             NCHN=NCHN+1
22506             ISIG(NCHN,1)=21
22507             ISIG(NCHN,2)=21
22508             ISIG(NCHN,3)=1+2*(IFL-3)
22509             SIGH(NCHN)=FACQQ1
22510             NCHN=NCHN+1
22511             ISIG(NCHN,1)=21
22512             ISIG(NCHN,2)=21
22513             ISIG(NCHN,3)=2+2*(IFL-3)
22514             SIGH(NCHN)=FACQQ2
22515           ENDIF
22516   930     CONTINUE
22517   940     CONTINUE
22518
22519         ELSEIF(ISUB.EQ.54) THEN
22520 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
22521           CALL PYWIDT(21,SH,WDTP,WDTE)
22522           WDTESU=0D0
22523           DO 950 I=1,MIN(8,MDCY(21,3))
22524             EF=KCHG(I,1)/3D0
22525             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22526      &      WDTE(I,4))
22527   950     CONTINUE
22528           FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
22529           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22530             NCHN=NCHN+1
22531             ISIG(NCHN,1)=21
22532             ISIG(NCHN,2)=22
22533             ISIG(NCHN,3)=1
22534             SIGH(NCHN)=FACQQ
22535           ENDIF
22536           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22537             NCHN=NCHN+1
22538             ISIG(NCHN,1)=22
22539             ISIG(NCHN,2)=21
22540             ISIG(NCHN,3)=1
22541             SIGH(NCHN)=FACQQ
22542           ENDIF
22543
22544         ELSEIF(ISUB.EQ.55) THEN
22545 C...g + Z -> f + fbar (g + Z -> q + qbar only)
22546
22547         ELSEIF(ISUB.EQ.56) THEN
22548 C...g + W -> f + f'bar (g + W -> q + q'bar only)
22549
22550         ELSEIF(ISUB.EQ.57) THEN
22551 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
22552
22553         ELSEIF(ISUB.EQ.58) THEN
22554 C...gamma + gamma -> f + fbar
22555           CALL PYWIDT(22,SH,WDTP,WDTE)
22556           WDTESU=0D0
22557           DO 960 I=1,MIN(12,MDCY(22,3))
22558             IF(I.LE.8) EF= KCHG(I,1)/3D0
22559             IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
22560             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22561      &      WDTE(I,4))
22562   960     CONTINUE
22563           FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
22564           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22565             NCHN=NCHN+1
22566             ISIG(NCHN,1)=22
22567             ISIG(NCHN,2)=22
22568             ISIG(NCHN,3)=1
22569             SIGH(NCHN)=FACFF
22570           ENDIF
22571
22572         ELSEIF(ISUB.EQ.59) THEN
22573 C...gamma + Z0 -> f + fbar
22574
22575         ELSEIF(ISUB.EQ.60) THEN
22576 C...gamma + W+/- -> f + fbar'
22577         ENDIF
22578
22579       ELSEIF(ISUB.LE.70) THEN
22580         IF(ISUB.EQ.61) THEN
22581 C...gamma + h0 -> f + fbar
22582
22583         ELSEIF(ISUB.EQ.62) THEN
22584 C...Z0 + Z0 -> f + fbar
22585
22586         ELSEIF(ISUB.EQ.63) THEN
22587 C...Z0 + W+/- -> f + fbar'
22588
22589         ELSEIF(ISUB.EQ.64) THEN
22590 C...Z0 + h0 -> f + fbar
22591
22592         ELSEIF(ISUB.EQ.65) THEN
22593 C...W+ + W- -> f + fbar
22594
22595         ELSEIF(ISUB.EQ.66) THEN
22596 C...W+/- + h0 -> f + fbar'
22597
22598         ELSEIF(ISUB.EQ.67) THEN
22599 C...h0 + h0 -> f + fbar
22600
22601         ELSEIF(ISUB.EQ.68) THEN
22602 C...g + g -> g + g
22603           IF(MSTP(5).LE.4) THEN
22604             FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
22605      &      2D0*TH/SH+TH2/SH2)*FACA
22606             FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
22607      &      2D0*SH/UH+SH2/UH2)*FACA
22608             FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
22609      &      2D0*UH/TH+UH2/TH2)
22610           ELSE
22611             GST=  (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
22612      &      16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
22613      &      4D0*REDGST*(SH + 2D0*TH)*
22614      &      (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
22615      &      2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
22616      &      2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
22617      &      32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
22618      &      SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
22619      &      96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
22620             GSU=  (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
22621      &      16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
22622      &      4D0*REDGSU*(SH + 2D0*UH)*
22623      &      (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
22624      &      2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
22625      &      2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
22626      &      32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
22627      &      SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
22628      &      96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
22629             GUT=  (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
22630      &      4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
22631      &      58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
22632      &      4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
22633      &      48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
22634      &      4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
22635      &      72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
22636      &      4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
22637      &      72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
22638      &      2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
22639      &      30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
22640      &      SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
22641      &      52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
22642             FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
22643             FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
22644             FACGG3=COMFAC*AS**2*9D0/4D0*GUT
22645           ENDIF
22646           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 970
22647           NCHN=NCHN+1
22648           ISIG(NCHN,1)=21
22649           ISIG(NCHN,2)=21
22650           ISIG(NCHN,3)=1
22651           SIGH(NCHN)=0.5D0*FACGG1
22652           NCHN=NCHN+1
22653           ISIG(NCHN,1)=21
22654           ISIG(NCHN,2)=21
22655           ISIG(NCHN,3)=2
22656           SIGH(NCHN)=0.5D0*FACGG2
22657           NCHN=NCHN+1
22658           ISIG(NCHN,1)=21
22659           ISIG(NCHN,2)=21
22660           ISIG(NCHN,3)=3
22661           SIGH(NCHN)=0.5D0*FACGG3
22662   970     CONTINUE
22663
22664         ELSEIF(ISUB.EQ.69) THEN
22665 C...gamma + gamma -> W+ + W-
22666           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22667           FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
22668           FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
22669      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
22670           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 980
22671           NCHN=NCHN+1
22672           ISIG(NCHN,1)=22
22673           ISIG(NCHN,2)=22
22674           ISIG(NCHN,3)=1
22675           SIGH(NCHN)=FACWW
22676   980     CONTINUE
22677
22678         ELSEIF(ISUB.EQ.70) THEN
22679 C...gamma + W+/- -> Z0 + W+/-
22680           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22681           FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
22682           FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
22683      &    (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
22684      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
22685           DO 1000 KCHW=1,-1,-2
22686             DO 990 ISDE=1,2
22687               IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 990
22688               NCHN=NCHN+1
22689               ISIG(NCHN,ISDE)=22
22690               ISIG(NCHN,3-ISDE)=24*KCHW
22691               ISIG(NCHN,3)=1
22692               SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
22693   990       CONTINUE
22694  1000     CONTINUE
22695         ENDIF
22696
22697       ELSEIF(ISUB.LE.80) THEN
22698         IF(ISUB.EQ.71) THEN
22699 C...Z0 + Z0 -> Z0 + Z0
22700           IF(SH.LE.4.01D0*SQMZ) GOTO 1030
22701
22702           IF(MSTP(46).LE.2) THEN
22703 C...Exact scattering ME:s for on-mass-shell gauge bosons
22704             BE2=1D0-4D0*SQMZ/SH
22705             TH=-0.5D0*SH*BE2*(1D0-CTH)
22706             UH=-0.5D0*SH*BE2*(1D0+CTH)
22707             IF(MAX(TH,UH).GT.-1D0) GOTO 1030
22708             SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
22709             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22710             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22711             THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
22712             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22713             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22714             UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
22715             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22716             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22717             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22718      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22719             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22720             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
22721      &      (ASHIM+ATHIM+AUHIM)**2)
22722             IF(MSTP(46).EQ.2) FACZZ=0D0
22723
22724           ELSE
22725 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22726             FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22727      &      ABS(A00U+2D0*A20U)**2
22728           ENDIF
22729           FACZZ=FACZZ*WIDS(23,1)
22730
22731           DO 1020 I=MMIN1,MMAX1
22732             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
22733             EI=KCHG(IABS(I),1)/3D0
22734             AI=SIGN(1D0,EI)
22735             VI=AI-4D0*EI*XWV
22736             AVI=AI**2+VI**2
22737             DO 1010 J=MMIN2,MMAX2
22738               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
22739               EJ=KCHG(IABS(J),1)/3D0
22740               AJ=SIGN(1D0,EJ)
22741               VJ=AJ-4D0*EJ*XWV
22742               AVJ=AJ**2+VJ**2
22743               NCHN=NCHN+1
22744               ISIG(NCHN,1)=I
22745               ISIG(NCHN,2)=J
22746               ISIG(NCHN,3)=1
22747               SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
22748  1010       CONTINUE
22749  1020     CONTINUE
22750  1030     CONTINUE
22751
22752         ELSEIF(ISUB.EQ.72) THEN
22753 C...Z0 + Z0 -> W+ + W-
22754           IF(SH.LE.4.01D0*SQMZ) GOTO 1060
22755
22756           IF(MSTP(46).LE.2) THEN
22757 C...Exact scattering ME:s for on-mass-shell gauge bosons
22758             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22759             CTH2=CTH**2
22760             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22761             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22762             IF(MAX(TH,UH).GT.-1D0) GOTO 1060
22763             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22764      &      (1D0-2D0*SQMZ/SH)
22765             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22766             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22767             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22768      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22769      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22770      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22771      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22772             ATWIM=0D0
22773             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22774      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22775      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22776      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22777      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22778             AUWIM=0D0
22779             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22780             A4IM=0D0
22781             FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22782      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22783             IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
22784             IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22785      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
22786             IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
22787      &      (ATWIM+AUWIM+A4IM)**2)
22788
22789           ELSE
22790 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22791             FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22792      &      ABS(A00U-A20U)**2
22793           ENDIF
22794           FACWW=FACWW*WIDS(24,1)
22795
22796           DO 1050 I=MMIN1,MMAX1
22797             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1050
22798             EI=KCHG(IABS(I),1)/3D0
22799             AI=SIGN(1D0,EI)
22800             VI=AI-4D0*EI*XWV
22801             AVI=AI**2+VI**2
22802             DO 1040 J=MMIN2,MMAX2
22803               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1040
22804               EJ=KCHG(IABS(J),1)/3D0
22805               AJ=SIGN(1D0,EJ)
22806               VJ=AJ-4D0*EJ*XWV
22807               AVJ=AJ**2+VJ**2
22808               NCHN=NCHN+1
22809               ISIG(NCHN,1)=I
22810               ISIG(NCHN,2)=J
22811               ISIG(NCHN,3)=1
22812               SIGH(NCHN)=FACWW*AVI*AVJ
22813  1040       CONTINUE
22814  1050     CONTINUE
22815  1060     CONTINUE
22816
22817         ELSEIF(ISUB.EQ.73) THEN
22818 C...Z0 + W+/- -> Z0 + W+/-
22819           IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 1090
22820
22821           IF(MSTP(46).LE.2) THEN
22822 C...Exact scattering ME:s for on-mass-shell gauge bosons
22823             BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
22824             EP1=1D0-(SQMZ-SQMW)/SH
22825             EP2=1D0+(SQMZ-SQMW)/SH
22826             TH=-0.5D0*SH*BE2*(1D0-CTH)
22827             UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
22828             IF(MAX(TH,UH).GT.-1D0) GOTO 1090
22829             THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
22830             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22831             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22832             ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
22833      &      1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
22834      &      2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
22835      &      1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
22836             ASWIM=0D0
22837             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
22838      &      (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
22839      &      (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
22840      &      BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
22841      &      (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
22842      &      1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
22843      &      (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
22844      &      (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
22845      &      (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
22846      &      (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
22847      &      ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
22848      &      (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
22849             AUWIM=0D0
22850             A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
22851      &      2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
22852             A4IM=0D0
22853             FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
22854      &      (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
22855             IF(MSTP(46).LE.0) FACZW=0D0
22856             IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
22857      &      (ATHIM+ASWIM+AUWIM+A4IM)**2)
22858             IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
22859      &      (ASWIM+AUWIM+A4IM)**2)
22860
22861           ELSE
22862 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22863             FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
22864      &      ABS(A20U+3D0*A11U*DBLE(CTH))**2
22865           ENDIF
22866           FACZW=FACZW*WIDS(23,2)
22867
22868           DO 1080 I=MMIN1,MMAX1
22869             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1080
22870             EI=KCHG(IABS(I),1)/3D0
22871             AI=SIGN(1D0,EI)
22872             VI=AI-4D0*EI*XWV
22873             AVI=AI**2+VI**2
22874             KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
22875             DO 1070 J=MMIN2,MMAX2
22876               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1070
22877               EJ=KCHG(IABS(J),1)/3D0
22878               AJ=SIGN(1D0,EJ)
22879               VJ=AI-4D0*EJ*XWV
22880               AVJ=AJ**2+VJ**2
22881               KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
22882               NCHN=NCHN+1
22883               ISIG(NCHN,1)=I
22884               ISIG(NCHN,2)=J
22885               ISIG(NCHN,3)=1
22886               SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
22887               NCHN=NCHN+1
22888               ISIG(NCHN,1)=I
22889               ISIG(NCHN,2)=J
22890               ISIG(NCHN,3)=2
22891               SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
22892  1070       CONTINUE
22893  1080     CONTINUE
22894  1090     CONTINUE
22895
22896         ELSEIF(ISUB.EQ.75) THEN
22897 C...W+ + W- -> gamma + gamma
22898
22899         ELSEIF(ISUB.EQ.76) THEN
22900 C...W+ + W- -> Z0 + Z0
22901           IF(SH.LE.4.01D0*SQMZ) GOTO 1120
22902
22903           IF(MSTP(46).LE.2) THEN
22904 C...Exact scattering ME:s for on-mass-shell gauge bosons
22905             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22906             CTH2=CTH**2
22907             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22908             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22909             IF(MAX(TH,UH).GT.-1D0) GOTO 1120
22910             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22911      &      (1D0-2D0*SQMZ/SH)
22912             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22913             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22914             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22915      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22916      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22917      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22918      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22919             ATWIM=0D0
22920             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22921      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22922      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22923      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22924      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22925             AUWIM=0D0
22926             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22927             A4IM=0D0
22928             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
22929      &      (SH/SQMW)**2*SH2
22930             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22931             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22932      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
22933             IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
22934      &      (ATWIM+AUWIM+A4IM)**2)
22935
22936           ELSE
22937 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22938             FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
22939      &      ABS(A00U-A20U)**2
22940           ENDIF
22941           FACZZ=FACZZ*WIDS(23,1)
22942
22943           DO 1110 I=MMIN1,MMAX1
22944             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1110
22945             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
22946             DO 1100 J=MMIN2,MMAX2
22947               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1100
22948               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
22949               IF(EI*EJ.GT.0D0) GOTO 1100
22950               NCHN=NCHN+1
22951               ISIG(NCHN,1)=I
22952               ISIG(NCHN,2)=J
22953               ISIG(NCHN,3)=1
22954               SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
22955  1100       CONTINUE
22956  1110     CONTINUE
22957  1120     CONTINUE
22958
22959         ELSEIF(ISUB.EQ.77) THEN
22960 C...W+/- + W+/- -> W+/- + W+/-
22961           IF(SH.LE.4.01D0*SQMW) GOTO 1150
22962
22963           IF(MSTP(46).LE.2) THEN
22964 C...Exact scattering ME:s for on-mass-shell gauge bosons
22965             BE2=1D0-4D0*SQMW/SH
22966             BE4=BE2**2
22967             CTH2=CTH**2
22968             CTH3=CTH**3
22969             TH=-0.5D0*SH*BE2*(1D0-CTH)
22970             UH=-0.5D0*SH*BE2*(1D0+CTH)
22971             IF(MAX(TH,UH).GT.-1D0) GOTO 1150
22972             SHANG=(1D0+BE2)**2
22973             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22974             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22975             THANG=(BE2-CTH)**2
22976             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22977             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22978             UHANG=(BE2+CTH)**2
22979             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22980             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22981             SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
22982             ASGRE=XW*SGZANG
22983             ASGIM=0D0
22984             ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
22985             ASZIM=0D0
22986             TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
22987      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
22988             ATGRE=0.5D0*XW*SH/TH*TGZANG
22989             ATGIM=0D0
22990             ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
22991             ATZIM=0D0
22992             UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
22993      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
22994             AUGRE=0.5D0*XW*SH/UH*UGZANG
22995             AUGIM=0D0
22996             AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
22997             AUZIM=0D0
22998             A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
22999             A4AIM=0D0
23000             A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23001             A4SIM=0D0
23002             FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23003      &      (SH/SQMW)**2*SH2
23004             IF(MSTP(46).LE.0) THEN
23005               AWWARE=ASHRE
23006               AWWAIM=ASHIM
23007               AWWSRE=0D0
23008               AWWSIM=0D0
23009             ELSEIF(MSTP(46).EQ.1) THEN
23010               AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23011               AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23012               AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23013               AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23014             ELSE
23015               AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23016               AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23017               AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23018               AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23019             ENDIF
23020             AWWA2=AWWARE**2+AWWAIM**2
23021             AWWS2=AWWSRE**2+AWWSIM**2
23022
23023           ELSE
23024 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23025             FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23026      &      ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23027             FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23028           ENDIF
23029
23030           DO 1140 I=MMIN1,MMAX1
23031             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1140
23032             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23033             DO 1130 J=MMIN2,MMAX2
23034               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1130
23035               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23036               IF(EI*EJ.LT.0D0) THEN
23037 C...W+W-
23038                 IF(MSTP(45).EQ.1) GOTO 1130
23039                 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23040                 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23041               ELSE
23042 C...W+W+/W-W-
23043                 IF(MSTP(45).EQ.2) GOTO 1130
23044                 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23045                 IF(MSTP(46).GE.3) FACWW=FWWS
23046                 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23047                 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23048               ENDIF
23049               NCHN=NCHN+1
23050               ISIG(NCHN,1)=I
23051               ISIG(NCHN,2)=J
23052               ISIG(NCHN,3)=1
23053               SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23054               IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23055  1130       CONTINUE
23056  1140     CONTINUE
23057  1150     CONTINUE
23058
23059         ELSEIF(ISUB.EQ.78) THEN
23060 C...W+/- + h0 -> W+/- + h0
23061
23062         ELSEIF(ISUB.EQ.79) THEN
23063 C...h0 + h0 -> h0 + h0
23064
23065         ELSEIF(ISUB.EQ.80) THEN
23066 C...q + gamma -> q' + pi+/-
23067           FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
23068           ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
23069           Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
23070           DELSH=UH*SQRT(ASSH*Q2FPSH)
23071           ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
23072           Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
23073           DELUH=SH*SQRT(ASUH*Q2FPUH)
23074           DO 1170 I=MAX(-2,MMINA),MIN(2,MMAXA)
23075             IF(I.EQ.0) GOTO 1170
23076             EI=KCHG(IABS(I),1)/3D0
23077             EJ=SIGN(1D0-ABS(EI),EI)
23078             DO 1160 ISDE=1,2
23079               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1160
23080               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1160
23081               NCHN=NCHN+1
23082               ISIG(NCHN,ISDE)=I
23083               ISIG(NCHN,3-ISDE)=22
23084               ISIG(NCHN,3)=1
23085               SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
23086  1160       CONTINUE
23087  1170     CONTINUE
23088
23089         ENDIF
23090
23091 C...C: 2 -> 2, tree diagrams with masses
23092
23093       ELSEIF(ISUB.LE.90) THEN
23094         IF(ISUB.EQ.81) THEN
23095 C...q + qbar -> Q + Qbar
23096           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23097           THQ=-0.5D0*SH*(1D0-BE34*CTH)
23098           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23099           FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
23100      &    2D0*SQMAVG/SH)
23101           IF(MSTP(5).GE.5) FACQQB=FACQQB*SH2*SQDQTS
23102           IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
23103           WID2=1D0
23104           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23105           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23106           FACQQB=FACQQB*WID2
23107           DO 1180 I=MMINA,MMAXA
23108             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23109      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1180
23110             NCHN=NCHN+1
23111             ISIG(NCHN,1)=I
23112             ISIG(NCHN,2)=-I
23113             ISIG(NCHN,3)=1
23114             SIGH(NCHN)=FACQQB
23115  1180     CONTINUE
23116
23117         ELSEIF(ISUB.EQ.82) THEN
23118 C...g + g -> Q + Qbar
23119           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23120           THQ=-0.5D0*SH*(1D0-BE34*CTH)
23121           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23122           THUHQ=THQ*UHQ-SQMAVG*SH
23123           IF(MSTP(34).EQ.0) THEN
23124             FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23125             FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23126           ELSE
23127             FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23128      &      THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23129             FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23130      &      UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23131           ENDIF
23132           IF(MSTP(5).GE.5) THEN
23133             FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23134      &      2.25D0*THQ*UHQ/SH2*SQDLGS
23135             FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23136      &      2.25D0*THQ*UHQ/SH2*SQDLGS
23137           ENDIF
23138           FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
23139           FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
23140           IF(MSTP(35).GE.1) THEN
23141             FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
23142             FACQQ1=FACQQ1*FATRE
23143             FACQQ2=FACQQ2*FATRE
23144           ENDIF
23145           WID2=1D0
23146           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23147           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23148           FACQQ1=FACQQ1*WID2
23149           FACQQ2=FACQQ2*WID2
23150           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1190
23151           NCHN=NCHN+1
23152           ISIG(NCHN,1)=21
23153           ISIG(NCHN,2)=21
23154           ISIG(NCHN,3)=1
23155           SIGH(NCHN)=FACQQ1
23156           NCHN=NCHN+1
23157           ISIG(NCHN,1)=21
23158           ISIG(NCHN,2)=21
23159           ISIG(NCHN,3)=2
23160           SIGH(NCHN)=FACQQ2
23161  1190     CONTINUE
23162
23163         ELSEIF(ISUB.EQ.83) THEN
23164 C...f + q -> f' + Q
23165           FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
23166           FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
23167           DO 1210 I=MMIN1,MMAX1
23168             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1210
23169             DO 1200 J=MMIN2,MMAX2
23170               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1200
23171               IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1200
23172               IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1200
23173               IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
23174      &        THEN
23175                 NCHN=NCHN+1
23176                 ISIG(NCHN,1)=I
23177                 ISIG(NCHN,2)=J
23178                 ISIG(NCHN,3)=1
23179                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23180      &          (IABS(I)+1)/2)*VINT(180+J)
23181                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
23182      &          (MINT(55)+1)/2)*VINT(180+J)
23183                 WID2=1D0
23184                 IF(I.GT.0) THEN
23185                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23186                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23187      &            WIDS(MINT(55),2)
23188                 ELSE
23189                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23190                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23191      &            WIDS(MINT(55),3)
23192                 ENDIF
23193                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23194                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23195               ENDIF
23196               IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
23197      &        THEN
23198                 NCHN=NCHN+1
23199                 ISIG(NCHN,1)=I
23200                 ISIG(NCHN,2)=J
23201                 ISIG(NCHN,3)=2
23202                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23203      &          (IABS(J)+1)/2)*VINT(180+I)
23204                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
23205      &          (MINT(55)+1)/2)*VINT(180+I)
23206                 IF(J.GT.0) THEN
23207                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23208                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23209      &            WIDS(MINT(55),2)
23210                 ELSE
23211                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23212                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23213      &            WIDS(MINT(55),3)
23214                 ENDIF
23215                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23216                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23217               ENDIF
23218  1200       CONTINUE
23219  1210     CONTINUE
23220
23221         ELSEIF(ISUB.EQ.84) THEN
23222 C...g + gamma -> Q + Qbar
23223           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23224           THQ=-0.5D0*SH*(1D0-BE34*CTH)
23225           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23226           FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
23227      &    (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
23228      &    (THQ*UHQ)
23229           IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
23230           WID2=1D0
23231           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23232           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23233           FACQQ=FACQQ*WID2
23234           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23235             NCHN=NCHN+1
23236             ISIG(NCHN,1)=21
23237             ISIG(NCHN,2)=22
23238             ISIG(NCHN,3)=1
23239             SIGH(NCHN)=FACQQ
23240           ENDIF
23241           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23242             NCHN=NCHN+1
23243             ISIG(NCHN,1)=22
23244             ISIG(NCHN,2)=21
23245             ISIG(NCHN,3)=1
23246             SIGH(NCHN)=FACQQ
23247           ENDIF
23248
23249         ELSEIF(ISUB.EQ.85) THEN
23250 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
23251           SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23252           THQ=-0.5D0*SH*(1D0-BE34*CTH)
23253           UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23254           FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
23255      &    ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
23256      &    (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
23257      &    SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
23258           IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
23259           IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
23260      &    FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
23261           WID2=1D0
23262           IF(MINT(56).EQ.6) WID2=WIDS(6,1)
23263           IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
23264           IF(MINT(56).EQ.17) WID2=WIDS(17,1)
23265           FACFF=FACFF*WID2
23266           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23267             NCHN=NCHN+1
23268             ISIG(NCHN,1)=22
23269             ISIG(NCHN,2)=22
23270             ISIG(NCHN,3)=1
23271             SIGH(NCHN)=FACFF
23272           ENDIF
23273
23274         ELSEIF(ISUB.EQ.86) THEN
23275 C...g + g -> J/Psi + g
23276           FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
23277      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23278      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23279           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23280             NCHN=NCHN+1
23281             ISIG(NCHN,1)=21
23282             ISIG(NCHN,2)=21
23283             ISIG(NCHN,3)=1
23284             SIGH(NCHN)=FACQQG
23285           ENDIF
23286
23287         ELSEIF(ISUB.EQ.87) THEN
23288 C...g + g -> chi_0c + g
23289           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23290           QGTW=(SH*TH*UH)/SH**3
23291           RGTW=SQM3/SH
23292           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23293      &    (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23294      &    6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
23295      &    PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
23296      &    2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
23297      &    (QGTW*(QGTW-RGTW*PGTW)**4)
23298           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23299             NCHN=NCHN+1
23300             ISIG(NCHN,1)=21
23301             ISIG(NCHN,2)=21
23302             ISIG(NCHN,3)=1
23303             SIGH(NCHN)=FACQQG
23304           ENDIF
23305
23306         ELSEIF(ISUB.EQ.88) THEN
23307 C...g + g -> chi_1c + g
23308           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23309           QGTW=(SH*TH*UH)/SH**3
23310           RGTW=SQM3/SH
23311           FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23312      &    PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
23313      &    5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
23314      &    (QGTW-RGTW*PGTW)**4
23315           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23316             NCHN=NCHN+1
23317             ISIG(NCHN,1)=21
23318             ISIG(NCHN,2)=21
23319             ISIG(NCHN,3)=1
23320             SIGH(NCHN)=FACQQG
23321           ENDIF
23322
23323         ELSEIF(ISUB.EQ.89) THEN
23324 C...g + g -> chi_2c + g
23325           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23326           QGTW=(SH*TH*UH)/SH**3
23327           RGTW=SQM3/SH
23328           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23329      &    (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23330      &    3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
23331      &    2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
23332      &    RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
23333      &    QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
23334           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23335             NCHN=NCHN+1
23336             ISIG(NCHN,1)=21
23337             ISIG(NCHN,2)=21
23338             ISIG(NCHN,3)=1
23339             SIGH(NCHN)=FACQQG
23340           ENDIF
23341         ENDIF
23342
23343 C...D: Mimimum bias processes
23344
23345       ELSEIF(ISUB.LE.100) THEN
23346         IF(ISUB.EQ.91) THEN
23347 C...Elastic scattering
23348           SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
23349
23350         ELSEIF(ISUB.EQ.92) THEN
23351 C...Single diffractive scattering (first side, i.e. XB)
23352           SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
23353
23354         ELSEIF(ISUB.EQ.93) THEN
23355 C...Single diffractive scattering (second side, i.e. AX)
23356           SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
23357
23358         ELSEIF(ISUB.EQ.94) THEN
23359 C...Double diffractive scattering
23360           SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
23361
23362         ELSEIF(ISUB.EQ.95) THEN
23363 C...Low-pT scattering
23364           SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
23365
23366         ELSEIF(ISUB.EQ.96) THEN
23367 C...Multiple interactions: sum of QCD processes
23368           CALL PYWIDT(21,SH,WDTP,WDTE)
23369
23370 C...q + q' -> q + q'
23371           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
23372           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
23373      &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
23374           FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
23375           FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
23376           RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
23377           DO 1230 I=-5,5
23378             IF(I.EQ.0) GOTO 1230
23379             DO 1220 J=-5,5
23380               IF(J.EQ.0) GOTO 1220
23381               NCHN=NCHN+1
23382               ISIG(NCHN,1)=I
23383               ISIG(NCHN,2)=J
23384               ISIG(NCHN,3)=111
23385               SIGH(NCHN)=FACQQ1
23386               IF(I.EQ.-J) SIGH(NCHN)=FACQQB
23387               IF(I.EQ.J) THEN
23388                 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
23389                 NCHN=NCHN+1
23390                 ISIG(NCHN,1)=I
23391                 ISIG(NCHN,2)=J
23392                 ISIG(NCHN,3)=112
23393                 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
23394               ENDIF
23395  1220       CONTINUE
23396  1230     CONTINUE
23397
23398 C...q + qbar -> q' + qbar' or g + g
23399           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
23400      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
23401           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23402      &    UH2/SH2)
23403           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23404      &    TH2/SH2)
23405           DO 1240 I=-5,5
23406             IF(I.EQ.0) GOTO 1240
23407             NCHN=NCHN+1
23408             ISIG(NCHN,1)=I
23409             ISIG(NCHN,2)=-I
23410             ISIG(NCHN,3)=121
23411             SIGH(NCHN)=FACQQB
23412             NCHN=NCHN+1
23413             ISIG(NCHN,1)=I
23414             ISIG(NCHN,2)=-I
23415             ISIG(NCHN,3)=131
23416             SIGH(NCHN)=0.5D0*FACGG1
23417             NCHN=NCHN+1
23418             ISIG(NCHN,1)=I
23419             ISIG(NCHN,2)=-I
23420             ISIG(NCHN,3)=132
23421             SIGH(NCHN)=0.5D0*FACGG2
23422  1240     CONTINUE
23423
23424 C...q + g -> q + g
23425           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
23426      &    UH/SH)*FACA
23427           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
23428      &    SH/UH)
23429           DO 1260 I=-5,5
23430             IF(I.EQ.0) GOTO 1260
23431             DO 1250 ISDE=1,2
23432               NCHN=NCHN+1
23433               ISIG(NCHN,ISDE)=I
23434               ISIG(NCHN,3-ISDE)=21
23435               ISIG(NCHN,3)=281
23436               SIGH(NCHN)=FACQG1
23437               NCHN=NCHN+1
23438               ISIG(NCHN,ISDE)=I
23439               ISIG(NCHN,3-ISDE)=21
23440               ISIG(NCHN,3)=282
23441               SIGH(NCHN)=FACQG2
23442  1250       CONTINUE
23443  1260     CONTINUE
23444
23445 C...g + g -> q + qbar (only d, u, s)
23446           IDC0=MDCY(21,2)-1
23447           FLAVWT=0D0
23448           IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
23449      &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
23450           IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
23451      &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
23452           IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
23453      &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
23454           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23455      &    UH2/SH2)*FLAVWT*FACA
23456           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23457      &    TH2/SH2)*FLAVWT*FACA
23458           NCHN=NCHN+1
23459           ISIG(NCHN,1)=21
23460           ISIG(NCHN,2)=21
23461           ISIG(NCHN,3)=531
23462           SIGH(NCHN)=FACQQ1
23463           NCHN=NCHN+1
23464           ISIG(NCHN,1)=21
23465           ISIG(NCHN,2)=21
23466           ISIG(NCHN,3)=532
23467           SIGH(NCHN)=FACQQ2
23468
23469 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
23470 C...cos(theta-hat)
23471           DO 1270 IFL=4,5
23472           SQMAVG=PMAS(IFL,1)**2
23473           IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
23474             BE34=SQRT(1D0-4D0*SQMAVG/SH)
23475             THQ=-0.5D0*SH*(1D0-BE34*CTH)
23476             UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23477             THUHQ=THQ*UHQ-SQMAVG*SH
23478             IF(MSTP(34).EQ.0) THEN
23479               FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23480               FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23481             ELSE
23482               FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23483      &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23484               FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23485      &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23486             ENDIF
23487             IF(MSTP(5).GE.5) THEN
23488               FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23489      &        2.25D0*THQ*UHQ/SH2*SQDLGS
23490               FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23491      &        2.25D0*THQ*UHQ/SH2*SQDLGS
23492             ENDIF
23493             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
23494             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
23495             NCHN=NCHN+1
23496             ISIG(NCHN,1)=21
23497             ISIG(NCHN,2)=21
23498             ISIG(NCHN,3)=531+2*(IFL-3)
23499             SIGH(NCHN)=FACQQ1
23500             NCHN=NCHN+1
23501             ISIG(NCHN,1)=21
23502             ISIG(NCHN,2)=21
23503             ISIG(NCHN,3)=532+2*(IFL-3)
23504             SIGH(NCHN)=FACQQ2
23505           ENDIF
23506  1270     CONTINUE
23507
23508 C...g + g -> g + g
23509           FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
23510      &    2D0*TH/SH+TH2/SH2)*FACA
23511           FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
23512      &    2D0*SH/UH+SH2/UH2)*FACA
23513           FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
23514      &    2D0*UH/TH+UH2/TH2)
23515           NCHN=NCHN+1
23516           ISIG(NCHN,1)=21
23517           ISIG(NCHN,2)=21
23518           ISIG(NCHN,3)=681
23519           SIGH(NCHN)=0.5D0*FACGG1
23520           NCHN=NCHN+1
23521           ISIG(NCHN,1)=21
23522           ISIG(NCHN,2)=21
23523           ISIG(NCHN,3)=682
23524           SIGH(NCHN)=0.5D0*FACGG2
23525           NCHN=NCHN+1
23526           ISIG(NCHN,1)=21
23527           ISIG(NCHN,2)=21
23528           ISIG(NCHN,3)=683
23529           SIGH(NCHN)=0.5D0*FACGG3
23530
23531         ELSEIF(ISUB.EQ.99) THEN
23532 C...f + gamma* -> f.
23533           IF(MINT(107).EQ.4) THEN
23534             Q2GA=VINT(307)
23535             P2GA=VINT(308)
23536             ISDE=2
23537           ELSE
23538             Q2GA=VINT(308)
23539             P2GA=VINT(307)
23540             ISDE=1
23541           ENDIF
23542           COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
23543           PM2RHO=PMAS(PYCOMP(113),1)**2
23544           IF(MSTP(19).EQ.0) THEN
23545             COMFAC=COMFAC/Q2GA
23546           ELSEIF(MSTP(19).EQ.1) THEN
23547             COMFAC=COMFAC/(Q2GA+PM2RHO)
23548           ELSEIF(MSTP(19).EQ.2) THEN
23549             COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23550           ELSE
23551             COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23552             W2GA=VINT(2)
23553             IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
23554               RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
23555      &        Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
23556               XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
23557             ELSE
23558               RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
23559      &        Q2GA**0.57D0)
23560               XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
23561             ENDIF
23562             COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
23563             IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
23564           ENDIF
23565           DO 1280 I=MMINA,MMAXA
23566             IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1280
23567             IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1280
23568             EI=KCHG(IABS(I),1)/3D0
23569             NCHN=NCHN+1
23570             ISIG(NCHN,ISDE)=I
23571             ISIG(NCHN,3-ISDE)=22
23572             ISIG(NCHN,3)=1
23573             SIGH(NCHN)=COMFAC*EI**2
23574  1280     CONTINUE
23575         ENDIF
23576
23577 C...E: 2 -> 1, loop diagrams
23578
23579       ELSEIF(ISUB.LE.110) THEN
23580         IF(ISUB.EQ.101) THEN
23581 C...g + g -> gamma*/Z0
23582
23583         ELSEIF(ISUB.EQ.102) THEN
23584 C...g + g -> h0 (or H0, or A0)
23585           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23586           HS=SHR*WDTP(0)
23587           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23588           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23589           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23590      &    FACBW=0D0
23591           HI=SHR*WDTP(13)/32D0
23592           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1290
23593           NCHN=NCHN+1
23594           ISIG(NCHN,1)=21
23595           ISIG(NCHN,2)=21
23596           ISIG(NCHN,3)=1
23597           SIGH(NCHN)=HI*FACBW*HF
23598  1290     CONTINUE
23599
23600         ELSEIF(ISUB.EQ.103) THEN
23601 C...gamma + gamma -> h0 (or H0, or A0)
23602           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23603           HS=SHR*WDTP(0)
23604           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23605           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23606           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23607      &    FACBW=0D0
23608           HI=SHR*WDTP(14)*2D0
23609           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1300
23610           NCHN=NCHN+1
23611           ISIG(NCHN,1)=22
23612           ISIG(NCHN,2)=22
23613           ISIG(NCHN,3)=1
23614           SIGH(NCHN)=HI*FACBW*HF
23615  1300     CONTINUE
23616
23617       ELSEIF(ISUB.EQ.104) THEN
23618 C...g + g -> chi_c0.
23619         KC=PYCOMP(10441)
23620         FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
23621      &  ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23622         IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23623         IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23624           NCHN=NCHN+1
23625           ISIG(NCHN,1)=21
23626           ISIG(NCHN,2)=21
23627           ISIG(NCHN,3)=1
23628           SIGH(NCHN)=FACBW
23629         ENDIF
23630
23631       ELSEIF(ISUB.EQ.105) THEN
23632 C...g + g -> chi_c2.
23633         KC=PYCOMP(445)
23634         FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
23635      &  ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23636         IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23637         IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23638           NCHN=NCHN+1
23639           ISIG(NCHN,1)=21
23640           ISIG(NCHN,2)=21
23641           ISIG(NCHN,3)=1
23642           SIGH(NCHN)=FACBW
23643         ENDIF
23644
23645 C...Continuation C: 2 -> 2, tree diagrams with masses.
23646
23647       ELSEIF(ISUB.EQ.106) THEN
23648 C...g + g -> J/Psi + gamma.
23649         EQ=2D0/3D0
23650         FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
23651      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23652      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23653         IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23654           NCHN=NCHN+1
23655           ISIG(NCHN,1)=21
23656           ISIG(NCHN,2)=21
23657           ISIG(NCHN,3)=1
23658           SIGH(NCHN)=FACQQG
23659         ENDIF
23660
23661       ELSEIF(ISUB.EQ.107) THEN
23662 C...g + gamma -> J/Psi + g.
23663         EQ=2D0/3D0
23664         FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
23665      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23666      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23667         IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23668           NCHN=NCHN+1
23669           ISIG(NCHN,1)=21
23670           ISIG(NCHN,2)=22
23671           ISIG(NCHN,3)=1
23672           SIGH(NCHN)=FACQQG
23673         ENDIF
23674         IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23675           NCHN=NCHN+1
23676           ISIG(NCHN,1)=22
23677           ISIG(NCHN,2)=21
23678           ISIG(NCHN,3)=1
23679           SIGH(NCHN)=FACQQG
23680         ENDIF
23681
23682       ELSEIF(ISUB.EQ.108) THEN
23683 C...gamma + gamma -> J/Psi + gamma.
23684         EQ=2D0/3D0
23685         FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
23686      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23687      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23688         IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23689           NCHN=NCHN+1
23690           ISIG(NCHN,1)=22
23691           ISIG(NCHN,2)=22
23692           ISIG(NCHN,3)=1
23693           SIGH(NCHN)=FACQQG
23694         ENDIF
23695
23696 C...F: 2 -> 2, box diagrams
23697
23698         ELSEIF(ISUB.EQ.110) THEN
23699 C...f + fbar -> gamma + h0
23700           THUH=MAX(TH*UH,SH*CKIN(3)**2)
23701           FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23702           FACHG=FACHG*WIDS(KFHIGG,2)
23703 C...Calculate loop contributions for intermediate gamma* and Z0
23704           CIGTOT=DCMPLX(0D0,0D0)
23705           CIZTOT=DCMPLX(0D0,0D0)
23706           JMAX=3*MSTP(1)+1
23707           DO 1310 J=1,JMAX
23708             IF(J.LE.2*MSTP(1)) THEN
23709               FNC=1D0
23710               EJ=KCHG(J,1)/3D0
23711               AJ=SIGN(1D0,EJ+0.1D0)
23712               VJ=AJ-4D0*EJ*XWV
23713               BALP=SQM4/(2D0*PMAS(J,1))**2
23714               BBET=SH/(2D0*PMAS(J,1))**2
23715             ELSEIF(J.LE.3*MSTP(1)) THEN
23716               FNC=3D0
23717               JL=2*(J-2*MSTP(1))-1
23718               EJ=KCHG(10+JL,1)/3D0
23719               AJ=SIGN(1D0,EJ+0.1D0)
23720               VJ=AJ-4D0*EJ*XWV
23721               BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23722               BBET=SH/(2D0*PMAS(10+JL,1))**2
23723             ELSE
23724               BALP=SQM4/(2D0*PMAS(24,1))**2
23725               BBET=SH/(2D0*PMAS(24,1))**2
23726             ENDIF
23727             BABI=1D0/(BALP-BBET)
23728             IF(BALP.LT.1D0) THEN
23729               F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23730               F1ALP=F0ALP**2
23731             ELSE
23732               F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23733      &        -DBLE(0.5D0*PARU(1)))
23734               F1ALP=-F0ALP**2
23735             ENDIF
23736             F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23737             IF(BBET.LT.1D0) THEN
23738               F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23739               F1BET=F0BET**2
23740             ELSE
23741               F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23742      &        -DBLE(0.5D0*PARU(1)))
23743               F1BET=-F0BET**2
23744             ENDIF
23745             F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23746             IF(J.LE.3*MSTP(1)) THEN
23747               FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23748      &        BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23749               CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23750               CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23751             ELSE
23752               TXW=XW/XW1
23753               CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23754      &        (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23755      &        DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23756               CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23757      &        (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23758      &        DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23759      &        (F1BET-F1ALP))
23760             ENDIF
23761  1310     CONTINUE
23762           CIGTOT=CIGTOT/DBLE(SH)
23763           CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23764 C...Loop over initial flavours
23765           DO 1320 I=MMINA,MMAXA
23766             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1320
23767             EI=KCHG(IABS(I),1)/3D0
23768             AI=SIGN(1D0,EI)
23769             VI=AI-4D0*EI*XWV
23770             FCOI=1D0
23771             IF(IABS(I).LE.10) FCOI=FACA/3D0
23772             NCHN=NCHN+1
23773             ISIG(NCHN,1)=I
23774             ISIG(NCHN,2)=-I
23775             ISIG(NCHN,3)=1
23776             SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23777      &      CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23778  1320     CONTINUE
23779
23780         ENDIF
23781
23782       ELSEIF(ISUB.LE.120) THEN
23783         IF(ISUB.EQ.111) THEN
23784 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23785           IF(MSTP(38).NE.0) THEN
23786 C...Simple case: only do gg <-> h exactly.
23787           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23788           FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23789      &    (TH**2+UH**2)/(SH*SQM4)
23790 C...Propagators: as simulated in PYOFSH and as desired
23791           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23792           GMMHC=SQRT(SQM4)*WDTP(0)
23793           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23794      &    ((SQM4-SQMH)**2+GMMHC**2)
23795           FACGH=FACGH*HBW4C/HBW4
23796           ELSE
23797 C...Messy case: do full loop integrals
23798           A5STUR=0D0
23799           A5STUI=0D0
23800           DO 1330 I=1,2*MSTP(1)
23801             SQMQ=PMAS(I,1)**2
23802             EPSS=4D0*SQMQ/SH
23803             EPSH=4D0*SQMQ/SQMH
23804             CALL PYWAUX(1,EPSS,W1SR,W1SI)
23805             CALL PYWAUX(1,EPSH,W1HR,W1HI)
23806             CALL PYWAUX(2,EPSS,W2SR,W2SI)
23807             CALL PYWAUX(2,EPSH,W2HR,W2HI)
23808             A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23809      &      (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23810             A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23811      &      (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23812  1330     CONTINUE
23813           FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23814      &    SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23815           FACGH=FACGH*WIDS(25,2)
23816           ENDIF
23817           DO 1340 I=MMINA,MMAXA
23818             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23819      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1340
23820             NCHN=NCHN+1
23821             ISIG(NCHN,1)=I
23822             ISIG(NCHN,2)=-I
23823             ISIG(NCHN,3)=1
23824             SIGH(NCHN)=FACGH
23825  1340     CONTINUE
23826
23827         ELSEIF(ISUB.EQ.112) THEN
23828 C...f + g -> f + h0 (q + g -> q + h0 only)
23829           IF(MSTP(38).NE.0) THEN
23830 C...Simple case: only do gg <-> h exactly.
23831           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23832           FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23833      &    (SH**2+UH**2)/(-TH*SQM4)
23834 C...Propagators: as simulated in PYOFSH and as desired
23835           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23836           GMMHC=SQRT(SQM4)*WDTP(0)
23837           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23838      &    ((SQM4-SQMH)**2+GMMHC**2)
23839           FACQH=FACQH*HBW4C/HBW4
23840           ELSE
23841 C...Messy case: do full loop integrals
23842           A5TSUR=0D0
23843           A5TSUI=0D0
23844           DO 1350 I=1,2*MSTP(1)
23845             SQMQ=PMAS(I,1)**2
23846             EPST=4D0*SQMQ/TH
23847             EPSH=4D0*SQMQ/SQMH
23848             CALL PYWAUX(1,EPST,W1TR,W1TI)
23849             CALL PYWAUX(1,EPSH,W1HR,W1HI)
23850             CALL PYWAUX(2,EPST,W2TR,W2TI)
23851             CALL PYWAUX(2,EPSH,W2HR,W2HI)
23852             A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23853      &      (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23854             A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23855      &      (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23856  1350     CONTINUE
23857           FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23858      &    SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23859           FACQH=FACQH*WIDS(25,2)
23860           ENDIF
23861           DO 1370 I=MMINA,MMAXA
23862             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1370
23863             DO 1360 ISDE=1,2
23864               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
23865               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
23866               NCHN=NCHN+1
23867               ISIG(NCHN,ISDE)=I
23868               ISIG(NCHN,3-ISDE)=21
23869               ISIG(NCHN,3)=1
23870               SIGH(NCHN)=FACQH
23871  1360       CONTINUE
23872  1370     CONTINUE
23873
23874         ELSEIF(ISUB.EQ.113) THEN
23875 C...g + g -> g + h0
23876           IF(MSTP(38).NE.0) THEN
23877 C...Simple case: only do gg <-> h exactly.
23878           CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23879           FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23880      &    (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23881 C...Propagators: as simulated in PYOFSH and as desired
23882           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23883           GMMHC=SQRT(SQM4)*WDTP(0)
23884           HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23885      &    ((SQM4-SQMH)**2+GMMHC**2)
23886           FACGH=FACGH*HBW4C/HBW4
23887           ELSE
23888 C...Messy case: do full loop integrals
23889           A2STUR=0D0
23890           A2STUI=0D0
23891           A2USTR=0D0
23892           A2USTI=0D0
23893           A2TUSR=0D0
23894           A2TUSI=0D0
23895           A4STUR=0D0
23896           A4STUI=0D0
23897           DO 1380 I=1,2*MSTP(1)
23898             SQMQ=PMAS(I,1)**2
23899             EPSS=4D0*SQMQ/SH
23900             EPST=4D0*SQMQ/TH
23901             EPSU=4D0*SQMQ/UH
23902             EPSH=4D0*SQMQ/SQMH
23903             IF(EPSH.LT.1D-6) GOTO 1380
23904             CALL PYWAUX(1,EPSS,W1SR,W1SI)
23905             CALL PYWAUX(1,EPST,W1TR,W1TI)
23906             CALL PYWAUX(1,EPSU,W1UR,W1UI)
23907             CALL PYWAUX(1,EPSH,W1HR,W1HI)
23908             CALL PYWAUX(2,EPSS,W2SR,W2SI)
23909             CALL PYWAUX(2,EPST,W2TR,W2TI)
23910             CALL PYWAUX(2,EPSU,W2UR,W2UI)
23911             CALL PYWAUX(2,EPSH,W2HR,W2HI)
23912             CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23913             CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23914             CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23915             CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23916             CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23917             CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23918             CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23919             CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23920             CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23921             CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23922             CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23923             CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23924             W3STUR=YHSTUR-Y3STUR-Y3UTSR
23925             W3STUI=YHSTUI-Y3STUI-Y3UTSI
23926             W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23927             W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23928             W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23929             W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23930             W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23931             W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23932             W3USTR=YHUSTR-Y3USTR-Y3TSUR
23933             W3USTI=YHUSTI-Y3USTI-Y3TSUI
23934             W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23935             W3UTSI=YHUTSI-Y3UTSI-Y3STUI
23936             B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
23937      &      (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
23938      &      (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
23939      &      (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
23940      &      (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
23941             B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
23942      &      (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
23943      &      W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
23944      &      (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
23945      &      (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
23946             B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
23947      &      (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
23948      &      (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
23949      &      (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
23950      &      (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
23951             B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
23952      &      (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
23953      &      W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
23954      &      (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
23955      &      (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
23956             B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
23957      &      (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
23958      &      (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
23959      &      (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
23960      &      (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
23961             B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
23962      &      (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
23963      &      W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
23964      &      (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
23965      &      (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
23966             B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
23967      &      (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
23968      &      (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
23969      &      (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
23970      &      (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
23971             B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
23972      &      (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
23973      &      W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
23974      &      (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
23975      &      (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
23976             B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
23977      &      (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
23978      &      (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
23979      &      (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
23980      &      (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
23981             B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
23982      &      (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
23983      &      W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
23984      &      (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
23985      &      (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
23986             B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
23987      &      (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
23988      &      (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
23989      &      (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
23990      &      (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
23991             B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
23992      &      (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
23993      &      W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
23994      &      (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
23995      &      (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
23996             B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
23997      &      (W2SR-W2HR+W3STUR))
23998             B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
23999             B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24000      &      (W2TR-W2HR+W3TUSR))
24001             B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24002             B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24003      &      (W2UR-W2HR+W3USTR))
24004             B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24005             A2STUR=A2STUR+B2STUR+B2SUTR
24006             A2STUI=A2STUI+B2STUI+B2SUTI
24007             A2USTR=A2USTR+B2USTR+B2UTSR
24008             A2USTI=A2USTI+B2USTI+B2UTSI
24009             A2TUSR=A2TUSR+B2TUSR+B2TSUR
24010             A2TUSI=A2TUSI+B2TUSI+B2TSUI
24011             A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24012             A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24013  1380     CONTINUE
24014           FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24015      &    SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24016      &    A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24017           FACGH=FACGH*WIDS(25,2)
24018           ENDIF
24019           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1390
24020           NCHN=NCHN+1
24021           ISIG(NCHN,1)=21
24022           ISIG(NCHN,2)=21
24023           ISIG(NCHN,3)=1
24024           SIGH(NCHN)=FACGH
24025  1390     CONTINUE
24026
24027         ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
24028 C...g + g -> gamma + gamma or g + g -> g + gamma
24029           A0STUR=0D0
24030           A0STUI=0D0
24031           A0TSUR=0D0
24032           A0TSUI=0D0
24033           A0UTSR=0D0
24034           A0UTSI=0D0
24035           A1STUR=0D0
24036           A1STUI=0D0
24037           A2STUR=0D0
24038           A2STUI=0D0
24039           ALST=LOG(-SH/TH)
24040           ALSU=LOG(-SH/UH)
24041           ALTU=LOG(TH/UH)
24042           IMAX=2*MSTP(1)
24043           IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
24044           DO 1400 I=1,IMAX
24045             EI=KCHG(IABS(I),1)/3D0
24046             EIWT=EI**2
24047             IF(ISUB.EQ.115) EIWT=EI
24048             SQMQ=PMAS(I,1)**2
24049             EPSS=4D0*SQMQ/SH
24050             EPST=4D0*SQMQ/TH
24051             EPSU=4D0*SQMQ/UH
24052             IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
24053               B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
24054      &        PARU(1)**2)
24055               B0STUI=0D0
24056               B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
24057               B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
24058               B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
24059               B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
24060               B1STUR=-1D0
24061               B1STUI=0D0
24062               B2STUR=-1D0
24063               B2STUI=0D0
24064             ELSE
24065               CALL PYWAUX(1,EPSS,W1SR,W1SI)
24066               CALL PYWAUX(1,EPST,W1TR,W1TI)
24067               CALL PYWAUX(1,EPSU,W1UR,W1UI)
24068               CALL PYWAUX(2,EPSS,W2SR,W2SI)
24069               CALL PYWAUX(2,EPST,W2TR,W2TI)
24070               CALL PYWAUX(2,EPSU,W2UR,W2UI)
24071               CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
24072               CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
24073               CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
24074               CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
24075               CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
24076               CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
24077               B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
24078      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
24079      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
24080      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
24081      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24082      &        0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24083               B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
24084      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
24085      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
24086      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
24087      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24088      &        0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24089               B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
24090      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
24091      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
24092      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
24093      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24094      &        0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
24095               B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
24096      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
24097      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
24098      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
24099      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24100      &        0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
24101               B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
24102      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
24103      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
24104      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
24105      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24106      &        0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
24107               B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
24108      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
24109      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
24110      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
24111      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24112      &        0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
24113               B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
24114      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
24115      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
24116      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24117               B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
24118      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
24119      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
24120      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24121               B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
24122      &        0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
24123      &        0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
24124               B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
24125      &        0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
24126      &        0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
24127             ENDIF
24128             A0STUR=A0STUR+EIWT*B0STUR
24129             A0STUI=A0STUI+EIWT*B0STUI
24130             A0TSUR=A0TSUR+EIWT*B0TSUR
24131             A0TSUI=A0TSUI+EIWT*B0TSUI
24132             A0UTSR=A0UTSR+EIWT*B0UTSR
24133             A0UTSI=A0UTSI+EIWT*B0UTSI
24134             A1STUR=A1STUR+EIWT*B1STUR
24135             A1STUI=A1STUI+EIWT*B1STUI
24136             A2STUR=A2STUR+EIWT*B2STUR
24137             A2STUI=A2STUI+EIWT*B2STUI
24138  1400     CONTINUE
24139           ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
24140      &    A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
24141           FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
24142           FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
24143           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1410
24144           NCHN=NCHN+1
24145           ISIG(NCHN,1)=21
24146           ISIG(NCHN,2)=21
24147           ISIG(NCHN,3)=1
24148           IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
24149           IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
24150  1410     CONTINUE
24151
24152         ELSEIF(ISUB.EQ.116) THEN
24153 C...g + g -> gamma + Z0
24154
24155         ELSEIF(ISUB.EQ.117) THEN
24156 C...g + g -> Z0 + Z0
24157
24158         ELSEIF(ISUB.EQ.118) THEN
24159 C...g + g -> W+ + W-
24160
24161         ENDIF
24162
24163 C...G: 2 -> 3, tree diagrams
24164
24165       ELSEIF(ISUB.LE.140) THEN
24166         IF(ISUB.EQ.121) THEN
24167 C...g + g -> Q + Qbar + h0
24168           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1420
24169           IA=KFPR(ISUBSV,2)
24170           PMF=PYMRUN(IA,SH)
24171           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24172      &    (0.5D0*PMF/PMAS(24,1))**2
24173           WID2=1D0
24174           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24175           FACQQH=FACQQH*WID2
24176           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24177             IKFI=1
24178             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24179             IF(IA.GT.10) IKFI=3
24180             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24181             IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24182               FACQQH=FACQQH/(1D0+RMSS(41))**2
24183               IF(IHIGG.NE.3) THEN
24184                 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24185      &          PARU(151+10*IHIGG))**2
24186               ENDIF
24187             ENDIF
24188           ENDIF
24189           CALL PYQQBH(WTQQBH)
24190           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24191           HS=SHR*WDTP(0)
24192           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24193           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24194           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24195      &    FACBW=0D0
24196           NCHN=NCHN+1
24197           ISIG(NCHN,1)=21
24198           ISIG(NCHN,2)=21
24199           ISIG(NCHN,3)=1
24200           SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24201  1420     CONTINUE
24202
24203         ELSEIF(ISUB.EQ.122) THEN
24204 C...q + qbar -> Q + Qbar + h0
24205           IA=KFPR(ISUBSV,2)
24206           PMF=PYMRUN(IA,SH)
24207           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24208      &    (0.5D0*PMF/PMAS(24,1))**2
24209           WID2=1D0
24210           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24211           FACQQH=FACQQH*WID2
24212           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24213             IKFI=1
24214             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24215             IF(IA.GT.10) IKFI=3
24216             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24217             IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24218               FACQQH=FACQQH/(1D0+RMSS(41))**2
24219               IF(IHIGG.NE.3) THEN
24220                 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24221      &          PARU(151+10*IHIGG))**2
24222               ENDIF
24223             ENDIF
24224           ENDIF
24225           CALL PYQQBH(WTQQBH)
24226           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24227           HS=SHR*WDTP(0)
24228           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24229           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24230           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24231      &    FACBW=0D0
24232           DO 1430 I=MMINA,MMAXA
24233             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24234      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1430
24235             NCHN=NCHN+1
24236             ISIG(NCHN,1)=I
24237             ISIG(NCHN,2)=-I
24238             ISIG(NCHN,3)=1
24239             SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24240  1430     CONTINUE
24241
24242         ELSEIF(ISUB.EQ.123) THEN
24243 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24244 C...inner process)
24245           FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24246           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24247      &    PARU(154+10*IHIGG)**2
24248           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24249      &    (VINT(216)-VINT(209)**2))**2
24250           FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24251           FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24252           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24253           HS=SHR*WDTP(0)
24254           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24255           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24256           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24257      &    FACBW=0D0
24258           DO 1450 I=MMIN1,MMAX1
24259             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1450
24260             IA=IABS(I)
24261             DO 1440 J=MMIN2,MMAX2
24262               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1440
24263               JA=IABS(J)
24264               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24265               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24266               VI=AI-4D0*EI*XWV
24267               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24268               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24269               VJ=AJ-4D0*EJ*XWV
24270               FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24271               FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24272               NCHN=NCHN+1
24273               ISIG(NCHN,1)=I
24274               ISIG(NCHN,2)=J
24275               ISIG(NCHN,3)=1
24276               SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24277  1440       CONTINUE
24278  1450     CONTINUE
24279
24280         ELSEIF(ISUB.EQ.124) THEN
24281 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24282 C...inner process)
24283           FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24284           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24285      &    PARU(155+10*IHIGG)**2
24286           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24287      &    (VINT(216)-VINT(209)**2))**2
24288           FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24289           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24290           HS=SHR*WDTP(0)
24291           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24292           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24293           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24294      &    FACBW=0D0
24295           DO 1470 I=MMIN1,MMAX1
24296             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
24297             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24298             DO 1460 J=MMIN2,MMAX2
24299               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
24300               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24301               IF(EI*EJ.GT.0D0) GOTO 1460
24302               FACLR=VINT(180+I)*VINT(180+J)
24303               NCHN=NCHN+1
24304               ISIG(NCHN,1)=I
24305               ISIG(NCHN,2)=J
24306               ISIG(NCHN,3)=1
24307               SIGH(NCHN)=FACLR*FACWW*FACBW
24308  1460       CONTINUE
24309  1470     CONTINUE
24310
24311         ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
24312 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
24313           PH=0D0
24314           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24315      &    PH=VINT(3)**2
24316           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24317      &    PH=VINT(4)**2
24318           IF(ISUB.EQ.131) THEN
24319             FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
24320      &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24321           ELSE
24322             FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24323           ENDIF
24324           DO 1490 I=MMINA,MMAXA
24325             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1490
24326             EI=KCHG(IABS(I),1)/3D0
24327             FACGQ=FGQ*EI**2
24328             DO 1480 ISDE=1,2
24329               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1480
24330               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1480
24331               NCHN=NCHN+1
24332               ISIG(NCHN,ISDE)=I
24333               ISIG(NCHN,3-ISDE)=22
24334               ISIG(NCHN,3)=1
24335               SIGH(NCHN)=FACGQ
24336  1480       CONTINUE
24337  1490     CONTINUE
24338
24339         ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
24340 C...f + gamma*_(T,L) -> f + gamma
24341           PH=0D0
24342           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24343      &    PH=VINT(3)**2
24344           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24345      &    PH=VINT(4)**2
24346           IF(ISUB.EQ.133) THEN
24347             FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
24348      &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24349           ELSE
24350             FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24351           ENDIF
24352           DO 1510 I=MMINA,MMAXA
24353             IF(I.EQ.0) GOTO 1510
24354             EI=KCHG(IABS(I),1)/3D0
24355             FACGQ=FGQ*EI**4
24356             DO 1500 ISDE=1,2
24357               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1500
24358               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1500
24359               NCHN=NCHN+1
24360               ISIG(NCHN,ISDE)=I
24361               ISIG(NCHN,3-ISDE)=22
24362               ISIG(NCHN,3)=1
24363               SIGH(NCHN)=FACGQ
24364  1500       CONTINUE
24365  1510     CONTINUE
24366
24367         ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
24368 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
24369           PH=0D0
24370           IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24371      &    PH=VINT(3)**2
24372           IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24373      &    PH=VINT(4)**2
24374           CALL PYWIDT(21,SH,WDTP,WDTE)
24375           WDTESU=0D0
24376           DO 1520 I=1,MIN(8,MDCY(21,3))
24377             EF=KCHG(I,1)/3D0
24378             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24379      &      WDTE(I,4))
24380  1520     CONTINUE
24381           IF(ISUB.EQ.135) THEN
24382             FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
24383      &      ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
24384           ELSE
24385             FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
24386           ENDIF
24387           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
24388             NCHN=NCHN+1
24389             ISIG(NCHN,1)=21
24390             ISIG(NCHN,2)=22
24391             ISIG(NCHN,3)=1
24392             SIGH(NCHN)=FACQQ
24393           ENDIF
24394           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
24395             NCHN=NCHN+1
24396             ISIG(NCHN,1)=22
24397             ISIG(NCHN,2)=21
24398             ISIG(NCHN,3)=1
24399             SIGH(NCHN)=FACQQ
24400           ENDIF
24401
24402         ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
24403 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
24404           PH1=0D0
24405           IF(VINT(3).LT.0D0) PH1=VINT(3)**2
24406           PH2=0D0
24407           IF(VINT(4).LT.0D0) PH2=VINT(4)**2
24408           CALL PYWIDT(22,SH,WDTP,WDTE)
24409           WDTESU=0D0
24410           DO 1530 I=1,MIN(12,MDCY(22,3))
24411             IF(I.LE.8) EF= KCHG(I,1)/3D0
24412             IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
24413             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24414      &      WDTE(I,4))
24415  1530     CONTINUE
24416           DLAMB2=(TH+UH)**2-4D0*PH1*PH2
24417           IF(ISUB.EQ.137) THEN
24418             FPARAM=-SH*(TH+UH)/DLAMB2
24419             FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
24420      &      (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
24421      &      2D0*PH1*PH2*FPARAM**2)
24422           ELSEIF(ISUB.EQ.138) THEN
24423             FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24424      &      PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
24425      &      2D0*PH1**2*(TH-UH)**2)
24426           ELSEIF(ISUB.EQ.139) THEN
24427             FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24428      &      PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
24429      &      2D0*PH2**2*(TH-UH)**2)
24430           ELSE
24431             FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
24432      &      PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
24433           ENDIF
24434           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
24435             NCHN=NCHN+1
24436             ISIG(NCHN,1)=22
24437             ISIG(NCHN,2)=22
24438             ISIG(NCHN,3)=1
24439             SIGH(NCHN)=FACFF
24440           ENDIF
24441
24442         ENDIF
24443
24444 C...H: 2 -> 1, tree diagrams, non-standard model processes
24445
24446       ELSEIF(ISUB.LE.160) THEN
24447         IF(ISUB.EQ.141) THEN
24448 C...f + fbar -> gamma*/Z0/Z'0
24449           SQMZP=PMAS(32,1)**2
24450           MINT(61)=2
24451           CALL PYWIDT(32,SH,WDTP,WDTE)
24452           HP0=AEM/3D0*SH
24453           HP1=AEM/3D0*XWC*SH
24454           HP2=HP1
24455           HS=SHR*VINT(117)
24456           HSP=SHR*WDTP(0)
24457           FACZP=4D0*COMFAC*3D0
24458           DO 1540 I=MMINA,MMAXA
24459             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
24460             EI=KCHG(IABS(I),1)/3D0
24461             AI=SIGN(1D0,EI)
24462             VI=AI-4D0*EI*XWV
24463             IA=IABS(I)
24464             IF(IA.LT.10) THEN
24465               IF(IA.LE.2) THEN
24466                 VPI=PARU(123-2*MOD(IABS(I),2))
24467                 API=PARU(124-2*MOD(IABS(I),2))
24468               ELSEIF(IA.LE.4) THEN
24469                 VPI=PARJ(182-2*MOD(IABS(I),2))
24470                 API=PARJ(183-2*MOD(IABS(I),2))
24471               ELSE
24472                 VPI=PARJ(190-2*MOD(IABS(I),2))
24473                 API=PARJ(191-2*MOD(IABS(I),2))
24474               ENDIF
24475             ELSE
24476               IF(IA.LE.12) THEN
24477                 VPI=PARU(127-2*MOD(IABS(I),2))
24478                 API=PARU(128-2*MOD(IABS(I),2))
24479               ELSEIF(IA.LE.14) THEN
24480                 VPI=PARJ(186-2*MOD(IABS(I),2))
24481                 API=PARJ(187-2*MOD(IABS(I),2))
24482               ELSE
24483                 VPI=PARJ(194-2*MOD(IABS(I),2))
24484                 API=PARJ(195-2*MOD(IABS(I),2))
24485               ENDIF
24486             ENDIF
24487             HI0=HP0
24488             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
24489             HI1=HP1
24490             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
24491             HI2=HP2
24492             IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
24493             NCHN=NCHN+1
24494             ISIG(NCHN,1)=I
24495             ISIG(NCHN,2)=-I
24496             ISIG(NCHN,3)=1
24497             SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
24498      &      (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
24499      &      VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
24500      &      (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
24501      &      ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
24502      &      ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
24503      &      ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
24504      &      (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
24505  1540     CONTINUE
24506
24507         ELSEIF(ISUB.EQ.142) THEN
24508 C...f + fbar' -> W'+/-
24509           SQMWP=PMAS(34,1)**2
24510           CALL PYWIDT(34,SH,WDTP,WDTE)
24511           HS=SHR*WDTP(0)
24512           FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
24513           HP=AEM/(24D0*XW)*SH
24514           DO 1560 I=MMIN1,MMAX1
24515             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1560
24516             IA=IABS(I)
24517             DO 1550 J=MMIN2,MMAX2
24518               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1550
24519               JA=IABS(J)
24520               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1550
24521               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24522      &        GOTO 1550
24523               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24524               HI=HP*(PARU(133)**2+PARU(134)**2)
24525               IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
24526      &        VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24527               NCHN=NCHN+1
24528               ISIG(NCHN,1)=I
24529               ISIG(NCHN,2)=J
24530               ISIG(NCHN,3)=1
24531               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
24532               SIGH(NCHN)=HI*FACBW*HF
24533  1550       CONTINUE
24534  1560     CONTINUE
24535
24536         ELSEIF(ISUB.EQ.143) THEN
24537 C...f + fbar' -> H+/-
24538           SQMHC=PMAS(37,1)**2
24539           CALL PYWIDT(37,SH,WDTP,WDTE)
24540           HS=SHR*WDTP(0)
24541           FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24542           HP=AEM/(8D0*XW)*SH/SQMW*SH
24543           DO 1580 I=MMIN1,MMAX1
24544             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
24545             IA=IABS(I)
24546             IM=(MOD(IA,10)+1)/2
24547             DO 1570 J=MMIN2,MMAX2
24548               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
24549               JA=IABS(J)
24550               JM=(MOD(JA,10)+1)/2
24551               IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1570
24552               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24553      &        GOTO 1570
24554               IF(MOD(IA,2).EQ.0) THEN
24555                 IU=IA
24556                 IL=JA
24557               ELSE
24558                 IU=JA
24559                 IL=IA
24560               ENDIF
24561               RML=PYMRUN(IL,SH)**2/SH
24562               RMU=PYMRUN(IU,SH)**2/SH
24563               HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24564               IF(IA.LE.10) HI=HI*FACA/3D0
24565               KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24566               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24567               NCHN=NCHN+1
24568               ISIG(NCHN,1)=I
24569               ISIG(NCHN,2)=J
24570               ISIG(NCHN,3)=1
24571               SIGH(NCHN)=HI*FACBW*HF
24572  1570       CONTINUE
24573  1580     CONTINUE
24574
24575         ELSEIF(ISUB.EQ.144) THEN
24576 C...f + fbar' -> R
24577           SQMR=PMAS(41,1)**2
24578           CALL PYWIDT(41,SH,WDTP,WDTE)
24579           HS=SHR*WDTP(0)
24580           FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
24581           HP=AEM/(12D0*XW)*SH
24582           DO 1600 I=MMIN1,MMAX1
24583             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1600
24584             IA=IABS(I)
24585             DO 1590 J=MMIN2,MMAX2
24586               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1590
24587               JA=IABS(J)
24588               IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1590
24589               HI=HP
24590               IF(IA.LE.10) HI=HI*FACA/3D0
24591               HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
24592               NCHN=NCHN+1
24593               ISIG(NCHN,1)=I
24594               ISIG(NCHN,2)=J
24595               ISIG(NCHN,3)=1
24596               SIGH(NCHN)=HI*FACBW*HF
24597  1590       CONTINUE
24598  1600     CONTINUE
24599
24600         ELSEIF(ISUB.EQ.145) THEN
24601 C...q + l -> LQ (leptoquark)
24602           SQMLQ=PMAS(42,1)**2
24603           CALL PYWIDT(42,SH,WDTP,WDTE)
24604           HS=SHR*WDTP(0)
24605           FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
24606           IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
24607           HP=AEM/4D0*SH
24608           KFLQQ=KFDP(MDCY(42,2),1)
24609           KFLQL=KFDP(MDCY(42,2),2)
24610           DO 1620 I=MMIN1,MMAX1
24611             IF(KFAC(1,I).EQ.0) GOTO 1620
24612             IA=IABS(I)
24613             IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1620
24614             DO 1610 J=MMIN2,MMAX2
24615               IF(KFAC(2,J).EQ.0) GOTO 1610
24616               JA=IABS(J)
24617               IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1610
24618               IF(I*J.NE.KFLQQ*KFLQL) GOTO 1610
24619               IF(JA.EQ.IA) GOTO 1610
24620               IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
24621               IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
24622               HI=HP*PARU(151)
24623               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
24624               NCHN=NCHN+1
24625               ISIG(NCHN,1)=I
24626               ISIG(NCHN,2)=J
24627               ISIG(NCHN,3)=1
24628               SIGH(NCHN)=HI*FACBW*HF
24629  1610       CONTINUE
24630  1620     CONTINUE
24631
24632         ELSEIF(ISUB.EQ.146) THEN
24633 C...e + gamma* -> e* (excited lepton)
24634           KFQSTR=KFPR(ISUB,1)
24635           KCQSTR=PYCOMP(KFQSTR)
24636           KFQEXC=MOD(KFQSTR,KEXCIT)
24637           CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24638           HS=SHR*WDTP(0)
24639           FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24640           QF=-PARU(157)/2D0-PARU(158)/2D0
24641           FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
24642           IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24643      &    FACBW=0D0
24644           HP=SH
24645           DO 1640 I=-KFQEXC,KFQEXC,2*KFQEXC
24646             DO 1630 ISDE=1,2
24647               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1630
24648               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1630
24649               HI=HP
24650               IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24651               IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24652               NCHN=NCHN+1
24653               ISIG(NCHN,ISDE)=I
24654               ISIG(NCHN,3-ISDE)=22
24655               ISIG(NCHN,3)=1
24656               SIGH(NCHN)=HI*FACBW*HF
24657  1630       CONTINUE
24658  1640     CONTINUE
24659
24660         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
24661 C...d + g -> d* and u + g -> u* (excited quarks)
24662           KFQSTR=KFPR(ISUB,1)
24663           KCQSTR=PYCOMP(KFQSTR)
24664           KFQEXC=MOD(KFQSTR,KEXCIT)
24665           CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24666           HS=SHR*WDTP(0)
24667           FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24668           FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
24669           IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24670      &    FACBW=0D0
24671           HP=SH
24672           DO 1660 I=-KFQEXC,KFQEXC,2*KFQEXC
24673             DO 1650 ISDE=1,2
24674               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1650
24675               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1650
24676               HI=HP
24677               IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24678               IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24679               NCHN=NCHN+1
24680               ISIG(NCHN,ISDE)=I
24681               ISIG(NCHN,3-ISDE)=21
24682               ISIG(NCHN,3)=1
24683               SIGH(NCHN)=HI*FACBW*HF
24684  1650       CONTINUE
24685  1660     CONTINUE
24686
24687         ELSEIF(ISUB.EQ.149) THEN
24688 C...g + g -> eta_tc
24689           KCTC=PYCOMP(KTECHN+331)
24690           CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
24691           HS=SHR*WDTP(0)
24692           FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
24693           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
24694           HP=SH
24695           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1670
24696           HI=HP*WDTP(3)
24697           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24698           NCHN=NCHN+1
24699           ISIG(NCHN,1)=21
24700           ISIG(NCHN,2)=21
24701           ISIG(NCHN,3)=1
24702           SIGH(NCHN)=HI*FACBW*HF
24703  1670     CONTINUE
24704
24705         ENDIF
24706
24707 C...I: 2 -> 2, tree diagrams, non-standard model processes
24708
24709       ELSEIF(ISUB.LE.200) THEN
24710         IF(ISUB.EQ.161) THEN
24711 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24712 C...(choice of only b and t to avoid kinematics problems)
24713           FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24714 C...H propagator: as simulated in PYOFSH and as desired
24715           SQMHC=PMAS(37,1)**2
24716           GMMHC=PMAS(37,1)*PMAS(37,2)
24717           HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24718           CALL PYWIDT(37,SQM4,WDTP,WDTE)
24719           GMMHCC=SQRT(SQM4)*WDTP(0)
24720           HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24721           FHCQ=FHCQ*HBW4C/HBW4
24722           DO 1690 I=MMINA,MMAXA
24723             IA=IABS(I)
24724             IF(IA.NE.5) GOTO 1690
24725             SQML=PYMRUN(IA,SH)**2
24726             IUA=IA+MOD(IA,2)
24727             SQMQ=PYMRUN(IUA,SH)**2
24728             FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24729      &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24730      &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24731      &      (SQMHC-SQMQ-SH)/SH)
24732             KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24733             DO 1680 ISDE=1,2
24734               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1680
24735               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1680
24736               NCHN=NCHN+1
24737               ISIG(NCHN,ISDE)=I
24738               ISIG(NCHN,3-ISDE)=21
24739               ISIG(NCHN,3)=1
24740               SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24741  1680       CONTINUE
24742  1690     CONTINUE
24743
24744         ELSEIF(ISUB.EQ.162) THEN
24745 C...q + g -> LQ + lbar; LQ=leptoquark
24746           SQMLQ=PMAS(42,1)**2
24747           FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
24748      &    (UH2+SQMLQ**2)/(UH-SQMLQ)**2
24749           KFLQQ=KFDP(MDCY(42,2),1)
24750           DO 1710 I=MMINA,MMAXA
24751             IF(IABS(I).NE.KFLQQ) GOTO 1710
24752             KCHLQ=ISIGN(1,I)
24753             DO 1700 ISDE=1,2
24754               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1700
24755               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1700
24756               NCHN=NCHN+1
24757               ISIG(NCHN,ISDE)=I
24758               ISIG(NCHN,3-ISDE)=21
24759               ISIG(NCHN,3)=1
24760               SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
24761  1700       CONTINUE
24762  1710     CONTINUE
24763
24764         ELSEIF(ISUB.EQ.163) THEN
24765 C...g + g -> LQ + LQbar; LQ=leptoquark
24766           SQMLQ=PMAS(42,1)**2
24767           FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
24768      &    (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
24769      &    (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
24770      &    ((TH-SQMLQ)*(UH-SQMLQ)))
24771           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
24772           NCHN=NCHN+1
24773           ISIG(NCHN,1)=21
24774           ISIG(NCHN,2)=21
24775 C...Since don't know proper colour flow, randomize between alternatives
24776           ISIG(NCHN,3)=INT(1.5D0+PYR(0))
24777           SIGH(NCHN)=FACLQ
24778  1720     CONTINUE
24779
24780         ELSEIF(ISUB.EQ.164) THEN
24781 C...q + qbar -> LQ + LQbar; LQ=leptoquark
24782           DELTA=0.25D0*(SQM3-SQM4)**2/SH
24783           SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
24784           TH=TH-DELTA
24785           UH=UH-DELTA
24786 C          SQMLQ=PMAS(42,1)**2
24787           FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
24788      &    (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
24789           FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
24790      &    (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
24791      &    ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
24792           KFLQQ=KFDP(MDCY(42,2),1)
24793           DO 1730 I=MMINA,MMAXA
24794             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24795      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1730
24796             NCHN=NCHN+1
24797             ISIG(NCHN,1)=I
24798             ISIG(NCHN,2)=-I
24799             ISIG(NCHN,3)=1
24800             SIGH(NCHN)=FACLQA
24801             IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
24802  1730     CONTINUE
24803
24804         ELSEIF(ISUB.EQ.165) THEN
24805 C...q + qbar -> l+ + l- (including contact term for compositeness)
24806           ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
24807           ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
24808           KFF=IABS(KFPR(ISUB,1))
24809           EF=KCHG(KFF,1)/3D0
24810           AF=SIGN(1D0,EF+0.1D0)
24811           VF=AF-4D0*EF*XWV
24812           VALF=VF+AF
24813           VARF=VF-AF
24814           FCOF=1D0
24815           IF(KFF.LE.10) FCOF=3D0
24816           WID2=1D0
24817           IF(KFF.EQ.6) WID2=WIDS(6,1)
24818           IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
24819           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
24820           DO 1740 I=MMINA,MMAXA
24821             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1740
24822             EI=KCHG(IABS(I),1)/3D0
24823             AI=SIGN(1D0,EI+0.1D0)
24824             VI=AI-4D0*EI*XWV
24825             VALI=VI+AI
24826             VARI=VI-AI
24827             FCOI=1D0
24828             IF(IABS(I).LE.10) FCOI=FACA/3D0
24829             IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
24830               FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
24831      &        (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
24832      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24833             ELSE
24834               FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
24835      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24836             ENDIF
24837             FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
24838      &      (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
24839             FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
24840             IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
24841      &      MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
24842             NCHN=NCHN+1
24843             ISIG(NCHN,1)=I
24844             ISIG(NCHN,2)=-I
24845             ISIG(NCHN,3)=1
24846             SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
24847  1740     CONTINUE
24848
24849         ELSEIF(ISUB.EQ.166) THEN
24850 C...q + q'bar -> l + nu_l (including contact term for compositeness)
24851           WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
24852           WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
24853           KFF=IABS(KFPR(ISUB,1))
24854           FCOF=1D0
24855           IF(KFF.LE.10) FCOF=3D0
24856           DO 1760 I=MMIN1,MMAX1
24857             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1760
24858             IA=IABS(I)
24859             DO 1750 J=MMIN2,MMAX2
24860               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1750
24861               JA=IABS(J)
24862               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
24863               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24864      &        GOTO 1750
24865               FCOI=1D0
24866               IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24867               WID2=1D0
24868               IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
24869      &        MOD(J,2).EQ.0)) THEN
24870                 IF(KFF.EQ.5) WID2=WIDS(6,2)
24871                 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
24872                 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
24873               ELSE
24874                 IF(KFF.EQ.5) WID2=WIDS(6,3)
24875                 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
24876                 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
24877               ENDIF
24878               NCHN=NCHN+1
24879               ISIG(NCHN,1)=I
24880               ISIG(NCHN,2)=J
24881               ISIG(NCHN,3)=1
24882               SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
24883               IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
24884      &        SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
24885  1750       CONTINUE
24886  1760     CONTINUE
24887
24888         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
24889 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
24890           KFQSTR=KFPR(ISUB,2)
24891           KCQSTR=PYCOMP(KFQSTR)
24892           KFQEXC=MOD(KFQSTR,KEXCIT)
24893           FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
24894           FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24895      &    (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24896 C...Propagators: as simulated in PYOFSH and as desired
24897           GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24898           HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24899           CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24900           GMMQC=SQRT(SQM4)*WDTP(0)
24901           HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24902           FACQSA=FACQSA*HBW4C/HBW4
24903           FACQSB=FACQSB*HBW4C/HBW4
24904 C...Branching ratios.
24905           BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24906           BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24907           DO 1780 I=MMIN1,MMAX1
24908             IA=IABS(I)
24909             IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1780
24910             DO 1770 J=MMIN2,MMAX2
24911               JA=IABS(J)
24912               IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1770
24913               IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
24914                 NCHN=NCHN+1
24915                 ISIG(NCHN,1)=I
24916                 ISIG(NCHN,2)=J
24917                 ISIG(NCHN,3)=1
24918                 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24919                 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24920                 NCHN=NCHN+1
24921                 ISIG(NCHN,1)=I
24922                 ISIG(NCHN,2)=J
24923                 ISIG(NCHN,3)=2
24924                 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24925                 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24926               ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
24927                 NCHN=NCHN+1
24928                 ISIG(NCHN,1)=I
24929                 ISIG(NCHN,2)=J
24930                 ISIG(NCHN,3)=1
24931                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24932                 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
24933                 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
24934               ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
24935                 NCHN=NCHN+1
24936                 ISIG(NCHN,1)=I
24937                 ISIG(NCHN,2)=J
24938                 ISIG(NCHN,3)=1
24939                 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24940                 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24941                 NCHN=NCHN+1
24942                 ISIG(NCHN,1)=I
24943                 ISIG(NCHN,2)=J
24944                 ISIG(NCHN,3)=2
24945                 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24946                 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24947               ELSEIF(I.EQ.-J) THEN
24948                 NCHN=NCHN+1
24949                 ISIG(NCHN,1)=I
24950                 ISIG(NCHN,2)=J
24951                 ISIG(NCHN,3)=1
24952                 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24953                 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24954                 NCHN=NCHN+1
24955                 ISIG(NCHN,1)=I
24956                 ISIG(NCHN,2)=J
24957                 ISIG(NCHN,3)=2
24958                 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24959                 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24960               ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
24961                 NCHN=NCHN+1
24962                 ISIG(NCHN,1)=I
24963                 ISIG(NCHN,2)=J
24964                 ISIG(NCHN,3)=1
24965                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24966                 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
24967                 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
24968               ENDIF
24969  1770       CONTINUE
24970  1780     CONTINUE
24971
24972         ELSEIF(ISUB.EQ.169) THEN
24973 C...q + qbar -> e + e* (excited lepton)
24974           KFQSTR=KFPR(ISUB,2)
24975           KCQSTR=PYCOMP(KFQSTR)
24976           KFQEXC=MOD(KFQSTR,KEXCIT)
24977           FACQSB=(COMFAC/6D0)*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24978      &    (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24979 C...Propagators: as simulated in PYOFSH and as desired
24980           GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24981           HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24982           CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24983           GMMQC=SQRT(SQM4)*WDTP(0)
24984           HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24985           FACQSB=FACQSB*HBW4C/HBW4
24986 C...Branching ratios.
24987           BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24988           BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24989           DO 1790 I=MMIN1,MMAX1
24990             IA=IABS(I)
24991             IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1790
24992             J=-I
24993             JA=IABS(J)
24994             IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1790
24995             NCHN=NCHN+1
24996             ISIG(NCHN,1)=I
24997             ISIG(NCHN,2)=J
24998             ISIG(NCHN,3)=1
24999             IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25000             IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25001             NCHN=NCHN+1
25002             ISIG(NCHN,1)=I
25003             ISIG(NCHN,2)=J
25004             ISIG(NCHN,3)=2
25005             IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25006             IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25007  1790     CONTINUE
25008
25009         ELSEIF(ISUB.EQ.191) THEN
25010 C...q + qbar -> rho_tc0.
25011           KCTC=PYCOMP(KTECHN+113)
25012           SQMRHT=PMAS(KCTC,1)**2
25013           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25014           HS=SHR*WDTP(0)
25015           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25016           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25017           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25018           ALPRHT=2.91D0*(3D0/PARP(144))
25019           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
25020           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25021           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25022           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25023           DO 1800 I=MMINA,MMAXA
25024             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
25025             IA=IABS(I)
25026             EI=KCHG(IABS(I),1)/3D0
25027             AI=SIGN(1D0,EI+0.1D0)
25028             VI=AI-4D0*EI*XWV
25029             VALI=0.5D0*(VI+AI)
25030             VARI=0.5D0*(VI-AI)
25031             HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25032      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
25033             IF(IA.LE.10) HI=HI*FACA/3D0
25034             NCHN=NCHN+1
25035             ISIG(NCHN,1)=I
25036             ISIG(NCHN,2)=-I
25037             ISIG(NCHN,3)=1
25038             SIGH(NCHN)=HI*FACBW*HF
25039  1800     CONTINUE
25040
25041         ELSEIF(ISUB.EQ.192) THEN
25042 C...q + qbar' -> rho_tc+/-.
25043           KCTC=PYCOMP(KTECHN+213)
25044           SQMRHT=PMAS(KCTC,1)**2
25045           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25046           HS=SHR*WDTP(0)
25047           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25048           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25049           ALPRHT=2.91D0*(3D0/PARP(144))
25050           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
25051      &    (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25052           DO 1820 I=MMIN1,MMAX1
25053             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1820
25054             IA=IABS(I)
25055             DO 1810 J=MMIN2,MMAX2
25056               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1810
25057               JA=IABS(J)
25058               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1810
25059               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25060      &        GOTO 1810
25061               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25062               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
25063               HI=HP
25064               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
25065               NCHN=NCHN+1
25066               ISIG(NCHN,1)=I
25067               ISIG(NCHN,2)=J
25068               ISIG(NCHN,3)=1
25069               SIGH(NCHN)=HI*FACBW*HF
25070  1810       CONTINUE
25071  1820     CONTINUE
25072
25073         ELSEIF(ISUB.EQ.193) THEN
25074 C...q + qbar -> omega_tc0.
25075           KCTC=PYCOMP(KTECHN+223)
25076           SQMOMT=PMAS(KCTC,1)**2
25077           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25078           HS=SHR*WDTP(0)
25079           FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
25080           IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25081           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25082           ALPRHT=2.91D0*(3D0/PARP(144))
25083           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
25084      &    (2D0*PARP(143)-1D0)**2
25085           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25086           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25087           DO 1830 I=MMINA,MMAXA
25088             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1830
25089             IA=IABS(I)
25090             EI=KCHG(IABS(I),1)/3D0
25091             AI=SIGN(1D0,EI+0.1D0)
25092             VI=AI-4D0*EI*XWV
25093             VALI=0.5D0*(VI+AI)
25094             VARI=0.5D0*(VI-AI)
25095             HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
25096      &      (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
25097             IF(IA.LE.10) HI=HI*FACA/3D0
25098             NCHN=NCHN+1
25099             ISIG(NCHN,1)=I
25100             ISIG(NCHN,2)=-I
25101             ISIG(NCHN,3)=1
25102             SIGH(NCHN)=HI*FACBW*HF
25103  1830     CONTINUE
25104
25105         ELSEIF(ISUB.EQ.194) THEN
25106 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
25107           KFA=KFPR(ISUBSV,1)
25108           ALPRHT=2.91D0*(3D0/PARP(144))
25109           HP=AEM**2*COMFAC
25110           TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25111           CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
25112
25113           QUPD=2D0*PARP(143)-1D0
25114           FAR=SQRT(AEM/ALPRHT)
25115           FAO=FAR*QUPD
25116           FZR=FAR*CT2W
25117           FZO=-FAO*TANW
25118           SFAR=FAR**2
25119           SFAO=FAO**2
25120           SFZR=FZR**2
25121           SFZO=FZO**2
25122           CALL PYWIDT(23,SH,WDTP,WDTE)
25123           SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
25124           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25125           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
25126           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25127           SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
25128           DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
25129      $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
25130           DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
25131           DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
25132           DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
25133
25134           XWRHT=1D0/(4D0*XW*(1D0-XW))
25135           KFF=IABS(KFPR(ISUB,1))
25136           EF=KCHG(KFF,1)/3D0
25137           AF=SIGN(1D0,EF+0.1D0)
25138           VF=AF-4D0*EF*XWV
25139           VALF=0.5D0*(VF+AF)
25140           VARF=0.5D0*(VF-AF)
25141           FCOF=1D0
25142           IF(KFF.LE.10) FCOF=3D0
25143
25144           WID2=1D0
25145           IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
25146           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
25147           DZZ=DZZ*DCMPLX(XWRHT,0D0)
25148           DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
25149
25150           DO 1840 I=MMINA,MMAXA
25151             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1840
25152             EI=KCHG(IABS(I),1)/3D0
25153             AI=SIGN(1D0,EI+0.1D0)
25154             VI=AI-4D0*EI*XWV
25155             VALI=0.5D0*(VI+AI)
25156             VARI=0.5D0*(VI-AI)
25157             FCOI=FCOF
25158             IF(IABS(I).LE.10) FCOI=FCOI/3D0
25159             DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
25160             DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
25161             DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
25162             DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
25163             FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
25164      &      (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
25165             NCHN=NCHN+1
25166             ISIG(NCHN,1)=I
25167             ISIG(NCHN,2)=-I
25168             ISIG(NCHN,3)=1
25169             SIGH(NCHN)=HP*FCOI*FACSIG*WID2
25170  1840     CONTINUE
25171
25172         ELSEIF(ISUB.EQ.195) THEN
25173 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
25174           KFA=KFPR(ISUBSV,1)
25175           KFB=KFA+1
25176           ALPRHT=2.91D0*(3D0/PARP(144))
25177           FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
25178
25179           FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
25180           CALL PYWIDT(24,SH,WDTP,WDTE)
25181           SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
25182           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25183           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
25184
25185           FCOF=1D0
25186           IF(KFA.LE.8) FCOF=3D0
25187           DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
25188           HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
25189
25190           DO 1860 I=MMIN1,MMAX1
25191             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1860
25192             IA=IABS(I)
25193             DO 1850 J=MMIN2,MMAX2
25194               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1850
25195               JA=IABS(J)
25196               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1850
25197               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25198      &        GOTO 1850
25199               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25200               HI=HP
25201               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
25202               NCHN=NCHN+1
25203               ISIG(NCHN,1)=I
25204               ISIG(NCHN,2)=J
25205               ISIG(NCHN,3)=1
25206               SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
25207  1850       CONTINUE
25208  1860     CONTINUE
25209
25210         ENDIF
25211
25212 CMRENNA++
25213 C...J: 2 -> 2, tree diagrams, SUSY processes
25214
25215       ELSEIF(ISUB.LE.210) THEN
25216         IF(ISUB.EQ.201) THEN
25217 C...f + fbar -> e_L + e_Lbar
25218           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25219           DO 1890 I=MMIN1,MMAX1
25220             IA=IABS(I)
25221             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1890
25222             EI=KCHG(IA,1)/3D0
25223             TT3I=SIGN(1D0,EI+1D-6)/2D0
25224             EJ=-1D0
25225             TT3J=-1D0/2D0
25226             FCOL=1D0
25227 C...Color factor for e+ e-
25228             IF(IA.GE.11) FCOL=3D0
25229             IF(ISUBSV.EQ.301) THEN
25230               A1=1D0
25231               A2=0D0
25232             ELSEIF(ILR.EQ.1) THEN
25233               A1=SFMIX(KFID,3)**2
25234               A2=SFMIX(KFID,4)**2
25235             ELSEIF(ILR.EQ.0) THEN
25236               A1=SFMIX(KFID,1)**2
25237               A2=SFMIX(KFID,2)**2
25238             ENDIF
25239             XLQ=(TT3J-EJ*XW)*A1
25240             XRQ=(-EJ*XW)*A2
25241             XLF=(TT3I-EI*XW)
25242             XRF=(-EI*XW)
25243             TAA=(EI*EJ)**2*(POLL+POLR)
25244             TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
25245             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
25246             TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
25247             TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25248             TNN=0.0D0
25249             TAN=0.0D0
25250             TZN=0.0D0
25251             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25252               FAC2=SQRT(2D0)
25253               TNN1=0D0
25254               TNN2=0D0
25255               TNN3=0D0
25256               DO 1880 II=1,4
25257                 DK=1D0/(TH-SMZ(II)**2)
25258                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25259      &          ZMIX(II,1))
25260                 FREK=FAC2*TANW*EI*ZMIX(II,1)
25261                 TNN1=TNN1+FLEK**2*DK
25262                 TNN2=TNN2+FREK**2*DK
25263                 DO 1870 JJ=1,4
25264                   DL=1D0/(TH-SMZ(JJ)**2)
25265                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25266      &            ZMIX(JJ,1))
25267                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25268                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25269  1870           CONTINUE
25270  1880         CONTINUE
25271               TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
25272      &        A2**2*TNN2**2*POLR)
25273               TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
25274      &        (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
25275               TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
25276      &        (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
25277               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25278      &        (1D0-SQMZ/SH)/SH
25279               TZN=TZN/XW**2/XW1
25280               TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
25281      &        A2*TNN2*POLR)/XW
25282             ENDIF
25283             FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
25284             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
25285             FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
25286             NCHN=NCHN+1
25287             ISIG(NCHN,1)=I
25288             ISIG(NCHN,2)=-I
25289             ISIG(NCHN,3)=1
25290             SIGH(NCHN)=FACQQ1+FACQQ2
25291  1890     CONTINUE
25292
25293         ELSEIF(ISUB.EQ.203) THEN
25294 C...f + fbar -> e_L + e_Rbar
25295           DO 1920 I=MMIN1,MMAX1
25296             IA=IABS(I)
25297             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920
25298             EI=KCHG(IABS(I),1)/3D0
25299             TT3I=SIGN(1D0,EI)/2D0
25300             EJ=-1
25301             TT3J=-1D0/2D0
25302             FCOL=1D0
25303 C...Color factor for e+ e-
25304             IF(IA.GE.11) FCOL=3D0
25305             A1=SFMIX(KFID,1)**2
25306             A2=SFMIX(KFID,2)**2
25307             XLQ=(TT3J-EJ*XW)
25308             XRQ=(-EJ*XW)
25309             XLF=(TT3I-EI*XW)
25310             XRF=(-EI*XW)
25311             TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
25312      &      /XW**2/XW1**2*A1*A2
25313             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25314             TNN=0.0D0
25315             TZN=0.0D0
25316             TNNA=0D0
25317             TNNB=0D0
25318             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25319               FAC2=SQRT(2D0)
25320               TNN1=0D0
25321               TNN2=0D0
25322               TNN3=0D0
25323               DO 1910 II=1,4
25324                 DK=1D0/(TH-SMZ(II)**2)
25325                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25326      &          ZMIX(II,1))
25327                 FREK=FAC2*TANW*EI*ZMIX(II,1)
25328                 TNN1=TNN1+FLEK**2*DK
25329                 TNN2=TNN2+FREK**2*DK
25330                 DO 1900 JJ=1,4
25331                   DL=1D0/(TH-SMZ(JJ)**2)
25332                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25333      &            ZMIX(JJ,1))
25334                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25335                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25336  1900           CONTINUE
25337  1910         CONTINUE
25338               TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
25339               TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
25340               TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
25341               TZN=(UH*TH-SQM3*SQM4)*A1*A2
25342               TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
25343               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25344      &        (1D0-SQMZ/SH)/SH
25345             ENDIF
25346             FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
25347             FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
25348             FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
25349 C%%%%%%%%%%%
25350             NCHN=NCHN+1
25351             ISIG(NCHN,1)=I
25352             ISIG(NCHN,2)=-I
25353             ISIG(NCHN,3)=1
25354             SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25355      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25356             NCHN=NCHN+1
25357             ISIG(NCHN,1)=I
25358             ISIG(NCHN,2)=-I
25359             ISIG(NCHN,3)=2
25360             SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25361      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25362  1920     CONTINUE
25363
25364         ELSEIF(ISUB.EQ.210) THEN
25365 C...q + qbar' -> W*- > ~l_L + ~nu_L
25366           FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
25367           FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
25368           DO 1940 I=MMIN1,MMAX1
25369             IA=IABS(I)
25370             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1940
25371             DO 1930 J=MMIN2,MMAX2
25372               JA=IABS(J)
25373               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1930
25374               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1930
25375               FCKM=3D0
25376               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25377               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25378               KCHW=2
25379               IF(KCHSUM.LT.0) KCHW=3
25380               NCHN=NCHN+1
25381               ISIG(NCHN,1)=I
25382               ISIG(NCHN,2)=J
25383               ISIG(NCHN,3)=1
25384               IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
25385                 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25386      &          WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25387               ELSE
25388                 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25389      &          WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25390               ENDIF
25391               SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
25392  1930       CONTINUE
25393  1940     CONTINUE
25394         ENDIF
25395
25396       ELSEIF(ISUB.LE.220) THEN
25397         IF(ISUB.EQ.213) THEN
25398 C...f + fbar -> ~nu_L + ~nu_Lbar
25399           IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
25400             FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25401      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25402           ELSE
25403             FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25404           ENDIF
25405           COMFAC=COMFAC*FACR
25406           PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
25407           XLL=0.5D0
25408           XLR=0.0D0
25409           DO 1950 I=MMIN1,MMAX1
25410             IA=IABS(I)
25411             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1950
25412             EI=KCHG(IA,1)/3D0
25413             FCOL=1D0
25414 C...Color factor for e+ e-
25415             IF(IA.GE.11) FCOL=3D0
25416             XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
25417             XRQ=-EI*XW
25418             TZC=0.0D0
25419             TCC=0.0D0
25420             IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
25421               TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
25422      &        (TH-SMW(2)**2)
25423               TCC=TZC**2
25424               TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
25425             ENDIF
25426             FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
25427             FACQQ2=TZC+TCC/4D0
25428             NCHN=NCHN+1
25429             ISIG(NCHN,1)=I
25430             ISIG(NCHN,2)=-I
25431             ISIG(NCHN,3)=1
25432             SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
25433      &      *AEM**2*FCOL/3D0/XW**2
25434  1950     CONTINUE
25435
25436         ELSEIF(ISUB.EQ.216) THEN
25437 C...q + qbar -> ~chi0_1 + ~chi0_1
25438           IF(IZID1.EQ.IZID2) THEN
25439             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25440           ELSE
25441             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25442      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25443           ENDIF
25444           FACXX=COMFAC*AEM**2/3D0/XW**2
25445           IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
25446           ZM12=SQM3
25447           ZM22=SQM4
25448           WU2 = (UH-ZM12)*(UH-ZM22)
25449           WT2 = (TH-ZM12)*(TH-ZM22)
25450           WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
25451           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25452           PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25453           DO 1960 I=1,4
25454             ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
25455             IF(IZID2.NE.IZID1) THEN
25456               ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25457             ENDIF
25458  1960     CONTINUE
25459           OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
25460      &    ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
25461           ORPP=DCONJG(OLPP)
25462           DO 1970 I=MMINA,MMAXA
25463             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1970
25464             EI=KCHG(IABS(I),1)/3D0
25465             T3I=SIGN(1D0,EI+1D-6)/2D0
25466             XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
25467             XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
25468             GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
25469      &      DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
25470             GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
25471             QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
25472             QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
25473      &      /DCMPLX(TH-XML2)
25474             QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
25475             QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
25476      &      -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
25477             FCOL=1D0
25478             IF(IABS(I).GE.11) FCOL=3D0
25479             FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25480      &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25481      &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25482      &      QRL*DCONJG(QRR)*POLR)*WS2
25483             NCHN=NCHN+1
25484             ISIG(NCHN,1)=I
25485             ISIG(NCHN,2)=-I
25486             ISIG(NCHN,3)=1
25487             SIGH(NCHN)=FACXX*FACGG1*FCOL
25488  1970     CONTINUE
25489         ENDIF
25490
25491       ELSEIF(ISUB.LE.230) THEN
25492         IF(ISUB.EQ.226) THEN
25493 C...f + fbar -> ~chi+_1 + ~chi-_1
25494           FACXX=COMFAC*AEM**2/3D0
25495           ZM12=SQM3
25496           ZM22=SQM4
25497           WU2 = (UH-ZM12)*(UH-ZM22)
25498           WT2 = (TH-ZM12)*(TH-ZM22)
25499           WS2 = SMW(IZID1)*SMW(IZID2)*SH
25500           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25501           PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25502           DIFF=0D0
25503           IF(IZID1.EQ.IZID2) DIFF=1D0
25504           DO 1980 I=1,2
25505             VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25506             UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25507             IF(IZID2.NE.IZID1) THEN
25508               VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
25509               UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
25510             ENDIF
25511  1980     CONTINUE
25512           OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
25513      &    VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
25514           ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
25515      &    UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
25516           DO 1990 I=MMINA,MMAXA
25517             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1990
25518             EI=KCHG(IABS(I),1)/3D0
25519             T3I=SIGN(1D0,EI+1D-6)/2D0
25520             QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
25521             QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
25522             QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
25523             IF(MOD(I,2).EQ.0) THEN
25524               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
25525               QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25526      &        PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
25527      &        DCMPLX(T3I/XW/(TH-XML2))
25528             ELSE
25529               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
25530               QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25531      &        PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
25532      &        DCMPLX(T3I/XW/(TH-XML2))
25533             ENDIF
25534             FCOL=1D0
25535             IF(IABS(I).GE.11) FCOL=3D0
25536             FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25537      &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25538      &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25539      &      QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
25540             NCHN=NCHN+1
25541             ISIG(NCHN,1)=I
25542             ISIG(NCHN,2)=-I
25543             ISIG(NCHN,3)=1
25544             IF(IZID1.EQ.IZID2) THEN
25545               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25546             ELSE
25547               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25548      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25549               NCHN=NCHN+1
25550               ISIG(NCHN,1)=I
25551               ISIG(NCHN,2)=-I
25552               ISIG(NCHN,3)=2
25553               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25554      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25555             ENDIF
25556  1990     CONTINUE
25557
25558         ELSEIF(ISUB.EQ.229) THEN
25559 C...q + qbar' -> ~chi0_1 + ~chi+-_1
25560           FACXX=COMFAC*AEM**2/6D0/XW**2
25561           ZM12=SQM3
25562           ZM22=SQM4
25563           WU2 = (UH-ZM12)*(UH-ZM22)
25564           WT2 = (TH-ZM12)*(TH-ZM22)
25565           WS2 = SMW(IZID1)*SMZ(IZID2)*SH
25566           RT2I = 1D0/SQRT(2D0)
25567           PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
25568      &    DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
25569           DO 2000 I=1,2
25570             VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25571             UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25572  2000     CONTINUE
25573           DO 2010 I=1,4
25574             ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25575  2010     CONTINUE
25576           OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25577      &    DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25578           OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25579      &    ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25580
25581           DO 2030 I=MMIN1,MMAX1
25582             IA=IABS(I)
25583             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 2030
25584             EI=KCHG(IA,1)/3D0
25585             T3I=SIGN(1D0,EI+1D-6)/2D0
25586             DO 2020 J=MMIN2,MMAX2
25587               JA=IABS(J)
25588               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 2020
25589               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2020
25590               EJ=KCHG(JA,1)/3D0
25591               T3J=SIGN(1D0,EJ+1D-6)/2D0
25592               FCKM=3D0
25593               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25594               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25595               KCHW=2
25596               IF(KCHSUM.LT.0) KCHW=3
25597               IF(MOD(IA,2).EQ.0) THEN
25598                 ZMI2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
25599                 ZMJ2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
25600                 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25601      &          TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25602                 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25603      &          ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25604      &          /DCMPLX(TH-ZMJ2)
25605               ELSE
25606                 ZMI2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
25607                 ZMJ2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
25608                 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25609      &          TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25610                 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25611      &          ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25612      &          /DCMPLX(TH-ZMI2)
25613               ENDIF
25614               ZINTR=DBLE(QLR*DCONJG(QLL))
25615               FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25616      &        2D0*ZINTR*WS2)
25617               NCHN=NCHN+1
25618               ISIG(NCHN,1)=I
25619               ISIG(NCHN,2)=J
25620               ISIG(NCHN,3)=1
25621               SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25622      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25623  2020       CONTINUE
25624  2030     CONTINUE
25625         ENDIF
25626
25627       ELSEIF(ISUB.LE.240) THEN
25628         IF(ISUB.EQ.237) THEN
25629 C...q + qbar -> gluino + ~chi0_1
25630           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25631      &    WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25632           FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25633           GM2=SQM3
25634           ZM2=SQM4
25635           DO 2040 I=MMINA,MMAXA
25636             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2040
25637             EI=KCHG(IABS(I),1)/3D0
25638             IA=IABS(I)
25639             XLQC = -TANW*EI*ZMIX(IZID,1)
25640             XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25641      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25642             XLQ2=XLQC**2
25643             XRQ2=XRQC**2
25644             XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25645             XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25646             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25647             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25648             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25649             SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25650             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25651             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25652             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25653             SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25654             NCHN=NCHN+1
25655             ISIG(NCHN,1)=I
25656             ISIG(NCHN,2)=-I
25657             ISIG(NCHN,3)=1
25658             SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25659  2040     CONTINUE
25660         ENDIF
25661
25662       ELSEIF(ISUB.LE.250) THEN
25663         IF(ISUB.EQ.241) THEN
25664 C...q + qbar' -> ~chi+-_1 + gluino
25665           FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25666           GM2=SQM3
25667           ZM2=SQM4
25668           FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25669           FAC0=UMIX(IZID,1)**2
25670           FAC1=VMIX(IZID,1)**2
25671           DO 2060 I=MMIN1,MMAX1
25672             IA=IABS(I)
25673             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 2060
25674             DO 2050 J=MMIN2,MMAX2
25675               JA=IABS(J)
25676               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 2050
25677               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2050
25678               FCKM=1D0
25679               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25680               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25681               KCHW=2
25682               IF(KCHSUM.LT.0) KCHW=3
25683               XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25684               XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25685               ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25686               AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25687               ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25688               XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25689               XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25690               ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25691               AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25692               ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25693      &        SH/(TH-XMU2)/(UH-XMD2))/2D0
25694               NCHN=NCHN+1
25695               ISIG(NCHN,1)=I
25696               ISIG(NCHN,2)=J
25697               ISIG(NCHN,3)=1
25698               SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25699      &        FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25700      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25701  2050       CONTINUE
25702  2060     CONTINUE
25703
25704         ELSEIF(ISUB.EQ.243) THEN
25705 C...q + qbar -> gluino + gluino
25706           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25707           XMT=SQM3-TH
25708           XMU=SQM3-UH
25709           DO 2070 I=MMINA,MMAXA
25710             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25711      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2070
25712             NCHN=NCHN+1
25713             XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25714             XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25715             FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25716      &      2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25717      &      XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25718      &      SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25719             XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25720             XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25721             FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25722      &      2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25723      &      XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25724      &      SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25725             ISIG(NCHN,1)=I
25726             ISIG(NCHN,2)=-I
25727             ISIG(NCHN,3)=1
25728 C...1/2 for identical particles
25729             SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25730  2070     CONTINUE
25731
25732         ELSEIF(ISUB.EQ.244) THEN
25733 C...g + g -> gluino + gluino
25734           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25735           XMT=SQM3-TH
25736           XMU=SQM3-UH
25737           FACQQ1=COMFAC*AS**2*9D0/4D0*(
25738      &    (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25739      &    (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25740           FACQQ2=COMFAC*AS**2*9D0/4D0*(
25741      &    (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25742      &    (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25743           FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25744      &    SQM3*(SH-4D0*SQM3)/XMT/XMU)
25745           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2080
25746           NCHN=NCHN+1
25747           ISIG(NCHN,1)=21
25748           ISIG(NCHN,2)=21
25749           ISIG(NCHN,3)=1
25750           SIGH(NCHN)=FACQQ1/2D0
25751           NCHN=NCHN+1
25752           ISIG(NCHN,1)=21
25753           ISIG(NCHN,2)=21
25754           ISIG(NCHN,3)=2
25755           SIGH(NCHN)=FACQQ2/2D0
25756           NCHN=NCHN+1
25757           ISIG(NCHN,1)=21
25758           ISIG(NCHN,2)=21
25759           ISIG(NCHN,3)=3
25760           SIGH(NCHN)=FACQQ3/2D0
25761  2080     CONTINUE
25762
25763         ELSEIF(ISUB.EQ.246) THEN
25764 C...g + q_j -> ~chi0_1 + ~q_j
25765           FAC0=COMFAC*AS*AEM/6D0/XW
25766           ZM2=SQM4
25767           QM2=SQM3
25768           FACZQ0=FAC0*( (ZM2-TH)/SH +
25769      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25770      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25771           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25772           DO 2100 I=-KFNSQ,KFNSQ,2*KFNSQ
25773             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2100
25774             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2100
25775             EI=KCHG(IABS(I),1)/3D0
25776             IA=IABS(I)
25777             XRQZ = -TANW*EI*ZMIX(IZID,1)
25778             XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25779      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25780             IF(ILR.EQ.0) THEN
25781               BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25782             ELSE
25783               BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25784             ENDIF
25785             FACZQ=FACZQ0*BS
25786             KCHQ=2
25787             IF(I.LT.0) KCHQ=3
25788             DO 2090 ISDE=1,2
25789               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2090
25790               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2090
25791               NCHN=NCHN+1
25792               ISIG(NCHN,ISDE)=I
25793               ISIG(NCHN,3-ISDE)=21
25794               ISIG(NCHN,3)=1
25795               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25796      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25797  2090       CONTINUE
25798  2100     CONTINUE
25799         ENDIF
25800
25801       ELSEIF(ISUB.LE.260) THEN
25802         IF(ISUB.EQ.254) THEN
25803 C...g + q_j -> ~chi1_1 + ~q_i
25804           FAC0=COMFAC*AS*AEM/12D0/XW
25805           ZM2=SQM4
25806           QM2=SQM3
25807           AU=UMIX(IZID,1)**2
25808           AD=VMIX(IZID,1)**2
25809           FACZQ0=FAC0*( (ZM2-TH)/SH +
25810      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25811      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25812           KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25813           IF(MOD(KFNSQ1,2).EQ.0) THEN
25814             KFNSQ=KFNSQ1-1
25815             KCHW=2
25816           ELSE
25817             KFNSQ=KFNSQ1+1
25818             KCHW=3
25819           ENDIF
25820           DO 2120 I=-KFNSQ,KFNSQ,2*KFNSQ
25821             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2120
25822             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2120
25823             IA=IABS(I)
25824             IF(MOD(IA,2).EQ.0) THEN
25825               FACZQ=FACZQ0*AU
25826             ELSE
25827               FACZQ=FACZQ0*AD
25828             ENDIF
25829             FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25830             KCHQ=2
25831             IF(I.LT.0) KCHQ=3
25832             KCHWQ=KCHW
25833             IF(I.LT.0) KCHWQ=5-KCHW
25834             DO 2110 ISDE=1,2
25835               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2110
25836               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2110
25837               NCHN=NCHN+1
25838               ISIG(NCHN,ISDE)=I
25839               ISIG(NCHN,3-ISDE)=21
25840               ISIG(NCHN,3)=1
25841               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25842      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25843  2110       CONTINUE
25844  2120     CONTINUE
25845
25846         ELSEIF(ISUB.EQ.258) THEN
25847 C...g + q_j -> gluino + ~q_i
25848           XG2=SQM4
25849           XQ2=SQM3
25850           XMT=XG2-TH
25851           XMU=XG2-UH
25852           XST=XQ2-TH
25853           XSU=XQ2-UH
25854           FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25855      &    ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25856      &    0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25857      &    (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25858           FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25859      &    (SH*(UH+XG2)
25860      &    +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25861      &    0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25862      &    (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25863           FACQG1=COMFAC*AS**2*FACQG1/2D0
25864           FACQG2=COMFAC*AS**2*FACQG2/2D0
25865           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25866           DO 2140 I=-KFNSQ,KFNSQ,2*KFNSQ
25867             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2140
25868             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 2140
25869             KCHQ=2
25870             IF(I.LT.0) KCHQ=3
25871             FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25872      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25873             DO 2130 ISDE=1,2
25874               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2130
25875               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2130
25876               NCHN=NCHN+1
25877               ISIG(NCHN,ISDE)=I
25878               ISIG(NCHN,3-ISDE)=21
25879               ISIG(NCHN,3)=1
25880               SIGH(NCHN)=FACQG1*FACSEL
25881               NCHN=NCHN+1
25882               ISIG(NCHN,ISDE)=I
25883               ISIG(NCHN,3-ISDE)=21
25884               ISIG(NCHN,3)=2
25885               SIGH(NCHN)=FACQG2*FACSEL
25886  2130       CONTINUE
25887  2140     CONTINUE
25888         ENDIF
25889
25890       ELSEIF(ISUB.LE.270) THEN
25891         IF(ISUB.EQ.261) THEN
25892 C...q_i + q_ibar -> ~t_1 + ~t_1bar
25893           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25894      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25895           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25896           FAC0=AS**2*4D0/9D0
25897           DO 2150 I=MMIN1,MMAX1
25898             IA=IABS(I)
25899             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2150
25900             IF(IA.GE.11.AND.IA.LE.18) THEN
25901               EI=KCHG(IA,1)/3D0
25902               EJ=KCHG(KFNSQ,1)/3D0
25903               T3I=SIGN(1D0,EI)/2D0
25904               T3J=SIGN(1D0,EJ)/2D0
25905               XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25906               XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25907               XLF=2D0*(T3I-EI*XW)
25908               XRF=2D0*(-EI*XW)
25909               TAA=0.5D0*(EI*EJ)**2
25910               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25911               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25912               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25913               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25914               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25915             ENDIF
25916             NCHN=NCHN+1
25917             ISIG(NCHN,1)=I
25918             ISIG(NCHN,2)=-I
25919             ISIG(NCHN,3)=1
25920             SIGH(NCHN)=FACQQ1*FAC0
25921  2150     CONTINUE
25922
25923         ELSEIF(ISUB.EQ.263) THEN
25924 C...f + fbar -> ~t1 + ~t2bar
25925           DO 2160 I=MMIN1,MMAX1
25926             IA=IABS(I)
25927             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2160
25928             EI=KCHG(IABS(I),1)/3D0
25929             TT3I=SIGN(1D0,EI)/2D0
25930             EJ=2D0/3D0
25931             TT3J=1D0/2D0
25932             FCOL=1D0
25933 C...Color factor for e+ e-
25934             IF(IA.GE.11) FCOL=3D0
25935             XLQ=2D0*(TT3J-EJ*XW)
25936             XRQ=2D0*(-EJ*XW)
25937             XLF=2D0*(TT3I-EI*XW)
25938             XRF=2D0*(-EI*XW)
25939             TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25940             TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25941             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25942 C...Factor of 2 for t1 t2bar + t2 t1bar
25943             FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25944             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25945             NCHN=NCHN+1
25946             ISIG(NCHN,1)=I
25947             ISIG(NCHN,2)=-I
25948             ISIG(NCHN,3)=1
25949             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25950      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25951             NCHN=NCHN+1
25952             ISIG(NCHN,1)=I
25953             ISIG(NCHN,2)=-I
25954             ISIG(NCHN,3)=2
25955             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25956      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25957  2160     CONTINUE
25958
25959         ELSEIF(ISUB.EQ.264) THEN
25960 C...g + g -> ~t_1 + ~t_1bar
25961           XSU=SQM3-UH
25962           XST=SQM3-TH
25963           FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25964      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25965           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25966           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25967           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2170
25968           NCHN=NCHN+1
25969           ISIG(NCHN,1)=21
25970           ISIG(NCHN,2)=21
25971           ISIG(NCHN,3)=1
25972           SIGH(NCHN)=FACQQ1
25973           NCHN=NCHN+1
25974           ISIG(NCHN,1)=21
25975           ISIG(NCHN,2)=21
25976           ISIG(NCHN,3)=2
25977           SIGH(NCHN)=FACQQ2
25978  2170     CONTINUE
25979         ENDIF
25980
25981       ELSEIF(ISUB.LE.280) THEN
25982         IF(ISUB.EQ.271) THEN
25983 C...q + q' -> ~q + ~q' (~g exchange)
25984           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25985           XMT=XMG2-TH
25986           XMU=XMG2-UH
25987           XSU1=SQM3-UH
25988           XSU2=SQM4-UH
25989           XST1=SQM3-TH
25990           XST2=SQM4-TH
25991           IF(ILR.EQ.1) THEN
25992             FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25993             FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25994             FACQQB=0.0D0
25995           ELSE
25996             FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25997             FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25998             FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25999      &      XMT/XMU )
26000           ENDIF
26001           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26002           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26003           DO 2190 I=-KFNSQI,KFNSQI,2*KFNSQI
26004             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2190
26005             IA=IABS(I)
26006             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2190
26007             KCHQ=2
26008             IF(I.LT.0) KCHQ=3
26009             DO 2180 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26010               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2180
26011               JA=IABS(J)
26012               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2180
26013               IF(I*J.LT.0) GOTO 2180
26014               NCHN=NCHN+1
26015               ISIG(NCHN,1)=I
26016               ISIG(NCHN,2)=J
26017               ISIG(NCHN,3)=1
26018               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26019      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26020               IF(I.EQ.J) THEN
26021                 IF(ILR.EQ.0) THEN
26022                   SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
26023      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26024                 ELSE
26025                   SIGH(NCHN)=0.5D0*FACQQ1*RKF*
26026      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26027      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26028                 ENDIF
26029                 NCHN=NCHN+1
26030                 ISIG(NCHN,1)=I
26031                 ISIG(NCHN,2)=J
26032                 ISIG(NCHN,3)=2
26033                 IF(ILR.EQ.0) THEN
26034                   SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
26035      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26036                 ELSE
26037                   SIGH(NCHN)=0.5D0*FACQQ2*RKF*
26038      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26039      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26040                 ENDIF
26041               ENDIF
26042  2180       CONTINUE
26043  2190     CONTINUE
26044
26045         ELSEIF(ISUB.EQ.274) THEN
26046 C...q + qbar' -> ~q + ~qbar'
26047           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
26048           XMT=XMG2-TH
26049           XMU=XMG2-UH
26050           IF(ILR.EQ.0) THEN
26051 C...Mrenna...Normalization.and.1/XMT
26052             FACQQ1=COMFAC*AS**2*2D0/9D0*(
26053      &      (UH*TH-SQM3*SQM4)/XMT**2 )
26054             FACQQB=COMFAC*AS**2*2D0/9D0*(
26055      &      (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
26056             FACQQB=FACQQB+FACQQ1
26057           ELSE
26058             FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
26059             FACQQB=FACQQ1
26060           ENDIF
26061           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26062           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26063           DO 2210 I=-KFNSQI,KFNSQI,2*KFNSQI
26064             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2210
26065             IA=IABS(I)
26066             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2210
26067             KCHQ=2
26068             IF(I.LT.0) KCHQ=3
26069             DO 2200 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26070               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2200
26071               JA=IABS(J)
26072               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2200
26073               IF(I*J.GT.0) GOTO 2200
26074               NCHN=NCHN+1
26075               ISIG(NCHN,1)=I
26076               ISIG(NCHN,2)=J
26077               ISIG(NCHN,3)=1
26078               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26079      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
26080               IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
26081      &        WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26082  2200       CONTINUE
26083  2210     CONTINUE
26084
26085         ELSEIF(ISUB.EQ.277) THEN
26086 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
26087 C...if i .eq. j covered in 274
26088           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
26089           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
26090           FAC0=0D0
26091           DO 2220 I=MMIN1,MMAX1
26092             IA=IABS(I)
26093             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
26094      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2220
26095             IF(IA.EQ.KFNSQ) GOTO 2220
26096             IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
26097               EI=KCHG(IA,1)/3D0
26098               EJ=KCHG(KFNSQ,1)/3D0
26099               T3J=SIGN(0.5D0,EJ)
26100               T3I=SIGN(1D0,EI)/2D0
26101               IF(ILR.EQ.0) THEN
26102                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
26103                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
26104               ELSE
26105                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
26106                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
26107               ENDIF
26108               XLF=2D0*(T3I-EI*XW)
26109               XRF=2D0*(-EI*XW)
26110               IF(ILR.EQ.0) THEN
26111                 XRQ=0D0
26112               ELSE
26113                 XLQ=0D0
26114               ENDIF
26115               TAA=0.5D0*(EI*EJ)**2
26116               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
26117               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
26118               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
26119               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
26120               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
26121             ELSEIF(IA.LE.6) THEN
26122               FAC0=AS**2*8D0/9D0/2D0
26123             ENDIF
26124             NCHN=NCHN+1
26125             ISIG(NCHN,1)=I
26126             ISIG(NCHN,2)=-I
26127             ISIG(NCHN,3)=1
26128             SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26129  2220     CONTINUE
26130
26131         ELSEIF(ISUB.EQ.279) THEN
26132 C...g + g -> ~q_j + ~q_jbar
26133           XSU=SQM3-UH
26134           XST=SQM3-TH
26135 C...5=RKF because ~t ~tbar treated separately
26136           FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
26137           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
26138           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
26139           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2230
26140           NCHN=NCHN+1
26141           ISIG(NCHN,1)=21
26142           ISIG(NCHN,2)=21
26143           ISIG(NCHN,3)=1
26144           SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26145           NCHN=NCHN+1
26146           ISIG(NCHN,1)=21
26147           ISIG(NCHN,2)=21
26148           ISIG(NCHN,3)=2
26149           SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26150  2230     CONTINUE
26151
26152         ENDIF
26153 CMRENNA--
26154
26155       ELSEIF(ISUB.LE.340) THEN
26156
26157       ELSEIF(ISUB.LE.360) THEN
26158
26159         IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
26160 C...l + l -> H_L++/-- or H_R++/--.
26161           KFRES=KFPR(ISUB,1)
26162           KFREC=PYCOMP(KFRES)
26163           CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26164           HS=SHR*WDTP(0)
26165           FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
26166           DO 2250 I=MMIN1,MMAX1
26167             IA=IABS(I)
26168             IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
26169      &      GOTO 2250
26170             DO 2240 J=MMIN2,MMAX2
26171               JA=IABS(J)
26172               IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
26173      &        GOTO 2240
26174               IF(I*J.LT.0) GOTO 2240
26175               KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26176               NCHN=NCHN+1
26177               ISIG(NCHN,1)=I
26178               ISIG(NCHN,2)=J
26179               ISIG(NCHN,3)=1
26180               HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
26181               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26182               SIGH(NCHN)=HI*FACBW*HF
26183  2240       CONTINUE
26184  2250     CONTINUE
26185
26186         ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
26187 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
26188           KFRES=KFPR(ISUB,1)
26189           KFREC=PYCOMP(KFRES)
26190 C...Propagators: as simulated in PYOFSH and as desired
26191           HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
26192      &    (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
26193           CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26194           GMMC=SQRT(SQM3)*WDTP(0)
26195           HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
26196           FHCC=COMFAC*AEM*HBW3C/HBW3
26197           DO 2270 I=MMINA,MMAXA
26198             IA=IABS(I)
26199             IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 2270
26200             SQML=PMAS(IA,1)**2
26201             J=ISIGN(KFPR(ISUB,2),-I)
26202             KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
26203             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
26204             SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
26205      &      (UH-SQM3)**2
26206             SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
26207      &      (TH-SQM4)*SH)/(TH-SQM4)**2
26208             SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
26209      &      SH)/(SH-SQML)**2
26210             SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
26211      &      3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
26212      &      ((UH-SQM3)*(TH-SQM4))
26213             SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
26214      &      SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
26215      &      ((UH-SQM3)*(SH-SQML))
26216             SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
26217      &      3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
26218      &      ((SH-SQML)*(TH-SQM4))
26219             SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
26220      &      PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
26221             DO 2260 ISDE=1,2
26222               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 2260
26223               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 2260
26224               NCHN=NCHN+1
26225               ISIG(NCHN,ISDE)=I
26226               ISIG(NCHN,3-ISDE)=22
26227               ISIG(NCHN,3)=0
26228               SIGH(NCHN)=FHCC*SMM*WIDSC
26229  2260       CONTINUE
26230  2270     CONTINUE
26231
26232         ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
26233 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
26234           KFRES=KFPR(ISUB,1)
26235           KFREC=PYCOMP(KFRES)
26236           SQMH=PMAS(KFREC,1)**2
26237           GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
26238 C...Propagators: H++/-- as simulated in PYOFSH and as desired
26239           HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
26240           CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26241           GMMH3=SQRT(SQM3)*WDTP(0)
26242           HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
26243           HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
26244           CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
26245           GMMH4=SQRT(SQM4)*WDTP(0)
26246           HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
26247 C...Kinematical and coupling functions
26248           FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
26249           XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
26250 C...Loop over allowed flavours
26251           DO 2280 I=MMINA,MMAXA
26252             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2280
26253             EI=KCHG(IABS(I),1)/3D0
26254             AI=SIGN(1D0,EI+0.1D0)
26255             VI=AI-4D0*EI*XWV
26256             FCOI=1D0
26257             IF(IABS(I).LE.10) FCOI=FACA/3D0
26258             IF(ISUB.EQ.349) THEN
26259               HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
26260               IF(IABS(I).LT.10) THEN
26261                 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26262      &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26263      &          (VI**2+AI**2)*XWHH**2*HBWZ)
26264               ELSE
26265                 IAOFF=181+3*((IABS(I)-11)/2)
26266                 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26267      &          (4D0*PARU(1))
26268                 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26269      &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26270      &          (VI**2+AI**2)*XWHH**2*HBWZ)+
26271      &          8D0*AEM*(EI*HSUM/(SH*TH)+
26272      &          (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
26273      &          4D0*HSUM**2/TH2
26274               ENDIF
26275             ELSE
26276               IF(IABS(I).LT.10) THEN
26277                 DSIGHH=8D0*AEM**2*EI**2/SH2
26278               ELSE
26279                 IAOFF=181+3*((IABS(I)-11)/2)
26280                 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26281      &          (4D0*PARU(1))
26282                 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
26283      &          4D0*HSUM**2/TH2
26284               ENDIF
26285             ENDIF
26286             NCHN=NCHN+1
26287             ISIG(NCHN,1)=I
26288             ISIG(NCHN,2)=-I
26289             ISIG(NCHN,3)=1
26290             SIGH(NCHN)=FACHH*FCOI*DSIGHH
26291  2280     CONTINUE
26292
26293         ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
26294 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
26295           KFRES=KFPR(ISUB,1)
26296           KFREC=PYCOMP(KFRES)
26297           SQMH=PMAS(KFREC,1)**2
26298           IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
26299           IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
26300      &    PMAS(PYCOMP(9900024),1)**2
26301           FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
26302           FACPRT=1D0/((VINT(204)**2-VINT(215))*
26303      &    (VINT(209)**2-VINT(216)))
26304           FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
26305      &    (VINT(209)**2+2D0*VINT(218)))
26306           CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26307           HS=SHR*WDTP(0)
26308           FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
26309           IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
26310      &    FACBW=0D0
26311           DO 2300 I=MMIN1,MMAX1
26312             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2300
26313             IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2300
26314             KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
26315             DO 2290 J=MMIN2,MMAX2
26316               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2290
26317               IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2290
26318               KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
26319               KCHH=KCHWI+KCHWJ
26320               IF(IABS(KCHH).NE.2) GOTO 2290
26321               FACLR=VINT(180+I)*VINT(180+J)
26322               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26323               IF(I.EQ.J.AND.IABS(I).GT.10) THEN
26324                 FACPRP=0.5D0*(FACPRT+FACPRU)**2
26325               ELSE
26326                 FACPRP=FACPRT**2
26327               ENDIF
26328               NCHN=NCHN+1
26329               ISIG(NCHN,1)=I
26330               ISIG(NCHN,2)=J
26331               ISIG(NCHN,3)=1
26332               SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
26333  2290       CONTINUE
26334  2300     CONTINUE
26335
26336         ELSEIF(ISUB.EQ.353) THEN
26337 C...f + fbar -> Z_R0
26338           SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26339           CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26340           HS=SHR*WDTP(0)
26341           FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
26342           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26343           HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
26344           DO 2310 I=MMINA,MMAXA
26345             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2310
26346             IF(IABS(I).LE.8) THEN
26347               EI=KCHG(IABS(I),1)/3D0
26348               AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
26349               VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
26350             ELSE
26351               AI=-(1D0-2D0*XW)
26352               VI=-1D0+4D0*XW
26353             ENDIF
26354             HI=HP*(VI**2+AI**2)
26355             IF(IABS(I).LE.10) HI=HI*FACA/3D0
26356             NCHN=NCHN+1
26357             ISIG(NCHN,1)=I
26358             ISIG(NCHN,2)=-I
26359             ISIG(NCHN,3)=1
26360             SIGH(NCHN)=HI*FACBW*HF
26361  2310     CONTINUE
26362
26363         ELSEIF(ISUB.EQ.354) THEN
26364 C...f + fbar' -> W_R+/-
26365           SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26366           CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26367           HS=SHR*WDTP(0)
26368           FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
26369           HP=AEM/(24D0*XW)*SH
26370           DO 2330 I=MMIN1,MMAX1
26371             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2330
26372             IA=IABS(I)
26373             DO 2320 J=MMIN2,MMAX2
26374               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2320
26375               JA=IABS(J)
26376               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2320
26377               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26378      &        GOTO 2320
26379               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26380               HI=HP*2D0
26381               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26382               NCHN=NCHN+1
26383               ISIG(NCHN,1)=I
26384               ISIG(NCHN,2)=J
26385               ISIG(NCHN,3)=1
26386               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
26387               SIGH(NCHN)=HI*FACBW*HF
26388  2320       CONTINUE
26389  2330     CONTINUE
26390         ENDIF
26391
26392       ELSEIF(ISUB.LE.380) THEN
26393
26394         IF(ISUB.EQ.361) THEN
26395 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26396           FACA=(SH**2*BE34**2-(TH-UH)**2)
26397           ALPRHT=2.91D0*(3D0/PARP(144))
26398           HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
26399           FAR=SQRT(AEM/ALPRHT)
26400           FAO=FAR*QUPD
26401           FZR=FAR*CT2W
26402           FZO=-FAO*TANW
26403           SFAR=FAR**2
26404           SFAO=FAO**2
26405           SFZR=FZR**2
26406           SFZO=FZO**2
26407           CALL PYWIDT(23,SH,WDTP,WDTE)
26408           SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26409           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26410           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26411           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26412           SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26413           DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26414      $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26415           DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26416           DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26417
26418           DO 2340 I=MMINA,MMAXA
26419             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2340
26420             IA=IABS(I)
26421             EI=KCHG(IABS(I),1)/3D0
26422             AI=SIGN(1D0,EI+0.1D0)
26423             VI=AI-4D0*EI*XWV
26424             VALI=0.25D0*(VI+AI)
26425             VARI=0.25D0*(VI-AI)
26426             F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
26427             F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
26428             HI=ABS(F2L)**2+ABS(F2R)**2
26429             IF(IA.LE.10) HI=HI/3D0
26430             NCHN=NCHN+1
26431             ISIG(NCHN,1)=I
26432             ISIG(NCHN,2)=-I
26433             ISIG(NCHN,3)=1
26434             IF(KFA.EQ.KFB) THEN
26435                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26436             ELSE
26437                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26438                NCHN=NCHN+1
26439                ISIG(NCHN,1)=I
26440                ISIG(NCHN,2)=-I
26441                ISIG(NCHN,3)=2
26442                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26443             ENDIF
26444  2340     CONTINUE
26445
26446         ELSEIF(ISUB.EQ.364) THEN
26447 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26448 C...W pi_tc
26449           VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
26450           AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH
26451
26452           ALPRHT=2.91D0*(3D0/PARP(144))
26453           HP=(1D0/24D0)*AEM**2*COMFAC*3D0
26454           FAR=SQRT(AEM/ALPRHT)
26455           FAO=FAR*QUPD
26456           FZR=FAR*CT2W
26457           FZO=-FAO*TANW
26458           SFAR=FAR**2
26459           SFAO=FAO**2
26460           SFZR=FZR**2
26461           SFZO=FZO**2
26462           CALL PYWIDT(23,SH,WDTP,WDTE)
26463           SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26464           CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26465           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26466           CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26467           SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26468           DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26469      $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26470           DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26471           DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26472           DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26473           DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26474
26475           DO 2350 I=MMINA,MMAXA
26476             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2350
26477             IA=IABS(I)
26478             EI=KCHG(IABS(I),1)/3D0
26479             AI=SIGN(1D0,EI+0.1D0)
26480             VI=AI-4D0*EI*XWV
26481             VALI=0.25D0*(VI+AI)
26482             VARI=0.25D0*(VI-AI)
26483             F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26484             F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26485             F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26486             F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26487             HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26488             F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26489             F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26490             F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26491             F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26492             HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26493             HI=HI+HJ
26494             IF(IA.LE.10) HI=HI/3D0
26495             NCHN=NCHN+1
26496             ISIG(NCHN,1)=I
26497             ISIG(NCHN,2)=-I
26498             ISIG(NCHN,3)=1
26499             IF(ISUBSV.NE.368) THEN
26500                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26501             ELSE
26502                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26503                NCHN=NCHN+1
26504                ISIG(NCHN,1)=I
26505                ISIG(NCHN,2)=-I
26506                ISIG(NCHN,3)=2
26507                SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26508             ENDIF
26509  2350     CONTINUE
26510
26511         ELSEIF(ISUB.EQ.370) THEN
26512 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26513
26514           FACA=(SH**2*BE34**2-(TH-UH)**2)
26515           ALPRHT=2.91D0*(3D0/PARP(144))
26516           HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW
26517
26518           FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26519           CALL PYWIDT(24,SH,WDTP,WDTE)
26520           SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26521           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26522           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26523
26524           DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26525           HP=HP*FWR**2/ABS(DETD)**2/SH**2
26526
26527           DO 2370 I=MMIN1,MMAX1
26528             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2370
26529             IA=IABS(I)
26530             DO 2360 J=MMIN2,MMAX2
26531               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2360
26532               JA=IABS(J)
26533               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2360
26534               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26535      &        GOTO 2360
26536               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26537               HI=HP
26538               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26539               NCHN=NCHN+1
26540               ISIG(NCHN,1)=I
26541               ISIG(NCHN,2)=J
26542               ISIG(NCHN,3)=1
26543               SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26544      &        WIDS(PYCOMP(KFB),2)
26545  2360       CONTINUE
26546  2370     CONTINUE
26547
26548         ELSEIF(ISUB.EQ.374) THEN
26549 C...f + fbar' -> gamma pi_tc
26550           VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
26551           AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26552
26553           ALPRHT=2.91D0*(3D0/PARP(144))
26554           HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH
26555
26556           FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26557           CALL PYWIDT(24,SH,WDTP,WDTE)
26558           SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26559           CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26560           SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26561
26562           DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26563           HP=HP*FWR**2/ABS(DETD)**2/SH**2
26564
26565           DO 2390 I=MMIN1,MMAX1
26566             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2390
26567             IA=IABS(I)
26568             DO 2380 J=MMIN2,MMAX2
26569               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2380
26570               JA=IABS(J)
26571               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2380
26572               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26573      &        GOTO 2380
26574               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26575               HI=HP
26576               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26577               NCHN=NCHN+1
26578               ISIG(NCHN,1)=I
26579               ISIG(NCHN,2)=J
26580               ISIG(NCHN,3)=1
26581               SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26582      &        WIDS(PYCOMP(KFB),2)
26583  2380       CONTINUE
26584  2390     CONTINUE
26585
26586         ENDIF
26587
26588       ELSEIF(ISUB.LE.400) THEN
26589
26590         IF(ISUB.EQ.391) THEN
26591 C...f + fbar -> G*.
26592           KFGSTR=KFPR(ISUB,1)
26593           KCGSTR=PYCOMP(KFGSTR)
26594           CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26595           HS=SHR*WDTP(0)
26596           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26597           FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
26598      &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26599           DO 2400 I=MMINA,MMAXA
26600             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2400
26601             HI=1D0
26602             IF(IABS(I).LE.10) HI=HI*FACA/3D0
26603             NCHN=NCHN+1
26604             ISIG(NCHN,1)=I
26605             ISIG(NCHN,2)=-I
26606             ISIG(NCHN,3)=1
26607             SIGH(NCHN)=FACG*HI
26608  2400     CONTINUE
26609
26610         ELSEIF(ISUB.EQ.392) THEN
26611 C...g + g -> G*.
26612           KFGSTR=KFPR(ISUB,1)
26613           KCGSTR=PYCOMP(KFGSTR)
26614           CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26615           HS=SHR*WDTP(0)
26616           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26617           FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
26618      &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26619           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2410
26620           NCHN=NCHN+1
26621           ISIG(NCHN,1)=21
26622           ISIG(NCHN,2)=21
26623           ISIG(NCHN,3)=1
26624           SIGH(NCHN)=FACG
26625  2410     CONTINUE
26626
26627         ELSEIF(ISUB.EQ.393) THEN
26628 C...q + qbar -> g + G*.
26629           KFGSTR=KFPR(ISUB,2)
26630           KCGSTR=PYCOMP(KFGSTR)
26631           FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
26632      &    (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
26633      &    3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
26634      &    2D0*SH2/(TH*UH))
26635 C...Propagators: as simulated in PYOFSH and as desired
26636           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26637           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26638           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26639           HS=SQRT(SQM4)*WDTP(0)
26640           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26641           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26642           FACG=FACG*HBW4C/HBW4
26643           DO 2420 I=MMINA,MMAXA
26644             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26645      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2420
26646             NCHN=NCHN+1
26647             ISIG(NCHN,1)=I
26648             ISIG(NCHN,2)=-I
26649             ISIG(NCHN,3)=1
26650             SIGH(NCHN)=FACG
26651  2420     CONTINUE
26652
26653         ELSEIF(ISUB.EQ.394) THEN
26654 C...q + g -> q + G*.
26655           KFGSTR=KFPR(ISUB,2)
26656           KCGSTR=PYCOMP(KFGSTR)
26657           FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
26658      &    (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
26659      &    3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
26660      &    2D0*TH2*TH/(UH*SH2))
26661 C...Propagators: as simulated in PYOFSH and as desired
26662           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26663           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26664           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26665           HS=SQRT(SQM4)*WDTP(0)
26666           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26667           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26668           FACG=FACG*HBW4C/HBW4
26669           DO 2440 I=MMINA,MMAXA
26670             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2440
26671             DO 2430 ISDE=1,2
26672               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2430
26673               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2430
26674               NCHN=NCHN+1
26675               ISIG(NCHN,ISDE)=I
26676               ISIG(NCHN,3-ISDE)=21
26677               ISIG(NCHN,3)=1
26678               SIGH(NCHN)=FACG
26679  2430       CONTINUE
26680  2440     CONTINUE
26681
26682         ELSEIF(ISUB.EQ.395) THEN
26683 C...g + g -> g + G*.
26684           KFGSTR=KFPR(ISUB,2)
26685           KCGSTR=PYCOMP(KFGSTR)
26686           FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
26687      &    ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
26688      &    3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
26689 C...Propagators: as simulated in PYOFSH and as desired
26690           GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26691           HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26692           CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26693           HS=SQRT(SQM4)*WDTP(0)
26694           HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26695           HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26696           FACG=FACG*HBW4C/HBW4
26697           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
26698             NCHN=NCHN+1
26699             ISIG(NCHN,1)=21
26700             ISIG(NCHN,2)=21
26701             ISIG(NCHN,3)=1
26702             SIGH(NCHN)=FACG
26703           ENDIF
26704
26705         ENDIF
26706       ENDIF
26707
26708 C...Multiply with parton distributions
26709       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
26710         DO 2450 ICHN=1,NCHN
26711           IF(MINT(45).GE.2) THEN
26712             KFL1=ISIG(ICHN,1)
26713             SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
26714           ENDIF
26715           IF(MINT(46).GE.2) THEN
26716             KFL2=ISIG(ICHN,2)
26717             SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
26718           ENDIF
26719           SIGS=SIGS+SIGH(ICHN)
26720  2450   CONTINUE
26721       ENDIF
26722
26723       RETURN
26724       END
26725
26726 C*********************************************************************
26727
26728 C...PYPDFU
26729 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
26730 C...parton distributions according to a few different parametrizations.
26731 C...Note that what is coded is x times the probability distribution,
26732 C...i.e. xq(x,Q2) etc.
26733
26734       SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
26735
26736 C...Double precision and integer declarations.
26737       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26738       IMPLICIT INTEGER(I-N)
26739       INTEGER PYK,PYCHGE,PYCOMP
26740 C...Commonblocks.
26741       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26742       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26743       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26744       COMMON/PYINT1/MINT(400),VINT(400)
26745       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
26746      &XPDIR(-6:6)
26747       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
26748 C...Local arrays.
26749       DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
26750      &XPPI(-6:6),XPPR(-6:6)
26751
26752 C...Interface to PDFLIB.
26753       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
26754       SAVE /W50513/
26755       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
26756      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
26757       CHARACTER*20 PARM(20)
26758       DATA VALUE/20*0D0/,PARM/20*' '/
26759
26760 C...Data related to Schuler-Sjostrand photon distributions.
26761       DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
26762
26763 C...Reset parton distributions.
26764       MINT(92)=0
26765       DO 100 KFL=-25,25
26766         XPQ(KFL)=0D0
26767   100 CONTINUE
26768
26769 C...Check x and particle species.
26770       IF(X.LE.0D0.OR.X.GE.1D0) THEN
26771         WRITE(MSTU(11),5000) X
26772         RETURN
26773       ENDIF
26774       KFA=IABS(KF)
26775       IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
26776      &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
26777      &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
26778      &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
26779      &KFA.NE.310.AND.KFA.NE.130) THEN
26780         WRITE(MSTU(11),5100) KF
26781         RETURN
26782       ENDIF
26783
26784 C...Electron (or muon or tau) parton distribution call.
26785       IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
26786         CALL PYPDEL(KFA,X,Q2,XPEL)
26787         DO 110 KFL=-25,25
26788           XPQ(KFL)=XPEL(KFL)
26789   110   CONTINUE
26790
26791 C...Photon parton distribution call (VDM+anomalous).
26792       ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
26793         IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
26794           CALL PYPDGA(X,Q2,XPGA)
26795           DO 120 KFL=-6,6
26796             XPQ(KFL)=XPGA(KFL)
26797   120     CONTINUE
26798         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
26799           Q2MX=Q2
26800           P2MX=0.36D0
26801           IF(MSTP(55).GE.7) P2MX=4.0D0
26802           IF(MSTP(57).EQ.0) Q2MX=P2MX
26803           P2=0D0
26804           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26805           CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26806           DO 130 KFL=-6,6
26807             XPQ(KFL)=XPGA(KFL)
26808   130     CONTINUE
26809           VINT(231)=P2MX
26810         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
26811           Q2MX=Q2
26812           P2MX=0.36D0
26813           IF(MSTP(55).GE.11) P2MX=4.0D0
26814           IF(MSTP(57).EQ.0) Q2MX=P2MX
26815           P2=0D0
26816           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26817           CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26818           DO 140 KFL=-6,6
26819             XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
26820   140     CONTINUE
26821           VINT(231)=P2MX
26822         ELSEIF(MSTP(56).EQ.2) THEN
26823 C...Call PDFLIB parton distributions.
26824           PARM(1)='NPTYPE'
26825           VALUE(1)=3
26826           PARM(2)='NGROUP'
26827           VALUE(2)=MSTP(55)/1000
26828           PARM(3)='NSET'
26829           VALUE(3)=MOD(MSTP(55),1000)
26830           IF(MINT(93).NE.3000000+MSTP(55)) THEN
26831             CALL PDFSET(PARM,VALUE)
26832             MINT(93)=3000000+MSTP(55)
26833           ENDIF
26834           XX=X
26835           QQ2=MAX(0D0,Q2MIN,Q2)
26836           IF(MSTP(57).EQ.0) QQ2=Q2MIN
26837           P2=0D0
26838           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26839           IP2=MSTP(60)
26840           IF(MSTP(55).EQ.5004) THEN
26841             IF(5D0*P2.LT.QQ2.AND.
26842      &      QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
26843      &      P2.GE.0D0.AND.P2.LT.10D0.AND.
26844      &      XX.GT.1D-4.AND.XX.LT.1D0) THEN
26845               CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26846      &        BOT,TOP,GLU)
26847             ELSE
26848               UPV=0D0
26849               DNV=0D0
26850               USEA=0D0
26851               DSEA=0D0
26852               STR=0D0
26853               CHM=0D0
26854               BOT=0D0
26855               TOP=0D0
26856               GLU=0D0
26857             ENDIF
26858           ELSE
26859             IF(P2.LT.QQ2) THEN
26860               CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26861      &        BOT,TOP,GLU)
26862             ELSE
26863               UPV=0D0
26864               DNV=0D0
26865               USEA=0D0
26866               DSEA=0D0
26867               STR=0D0
26868               CHM=0D0
26869               BOT=0D0
26870               TOP=0D0
26871               GLU=0D0
26872             ENDIF
26873           ENDIF
26874           VINT(231)=Q2MIN
26875           XPQ(0)=GLU
26876           XPQ(1)=DNV
26877           XPQ(-1)=DNV
26878           XPQ(2)=UPV
26879           XPQ(-2)=UPV
26880           XPQ(3)=STR
26881           XPQ(-3)=STR
26882           XPQ(4)=CHM
26883           XPQ(-4)=CHM
26884           XPQ(5)=BOT
26885           XPQ(-5)=BOT
26886           XPQ(6)=TOP
26887           XPQ(-6)=TOP
26888         ELSE
26889           WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
26890         ENDIF
26891
26892 C...Pion/gammaVDM parton distribution call.
26893       ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
26894      &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
26895         IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
26896      &  MSTP(55).LE.12) THEN
26897           ISET=1+MOD(MSTP(55)-1,4)
26898           Q2MX=Q2
26899           P2MX=0.36D0
26900           IF(ISET.GE.3) P2MX=4.0D0
26901           IF(MSTP(57).EQ.0) Q2MX=P2MX
26902           P2=0D0
26903           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26904           CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26905           DO 150 KFL=-6,6
26906             XPQ(KFL)=XPVMD(KFL)
26907   150     CONTINUE
26908           VINT(231)=P2MX
26909         ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
26910           CALL PYPDPI(X,Q2,XPPI)
26911           DO 160 KFL=-6,6
26912             XPQ(KFL)=XPPI(KFL)
26913   160     CONTINUE
26914         ELSEIF(MSTP(54).EQ.2) THEN
26915 C...Call PDFLIB parton distributions.
26916           PARM(1)='NPTYPE'
26917           VALUE(1)=2
26918           PARM(2)='NGROUP'
26919           VALUE(2)=MSTP(53)/1000
26920           PARM(3)='NSET'
26921           VALUE(3)=MOD(MSTP(53),1000)
26922           IF(MINT(93).NE.2000000+MSTP(53)) THEN
26923             CALL PDFSET(PARM,VALUE)
26924             MINT(93)=2000000+MSTP(53)
26925           ENDIF
26926           XX=X
26927           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
26928           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
26929           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
26930           VINT(231)=Q2MIN
26931           XPQ(0)=GLU
26932           XPQ(1)=DSEA
26933           XPQ(-1)=UPV+DSEA
26934           XPQ(2)=UPV+USEA
26935           XPQ(-2)=USEA
26936           XPQ(3)=STR
26937           XPQ(-3)=STR
26938           XPQ(4)=CHM
26939           XPQ(-4)=CHM
26940           XPQ(5)=BOT
26941           XPQ(-5)=BOT
26942           XPQ(6)=TOP
26943           XPQ(-6)=TOP
26944         ELSE
26945           WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
26946         ENDIF
26947
26948 C...Anomalous photon parton distribution call.
26949       ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
26950         Q2MX=Q2
26951         P2MX=PARP(15)**2
26952         IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
26953           IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
26954           IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
26955           IF(MSTP(57).EQ.0) Q2MX=P2MX
26956           P2=0D0
26957           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26958           CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26959           DO 170 KFL=-6,6
26960             XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
26961   170     CONTINUE
26962           VINT(231)=P2MX
26963         ELSEIF(MSTP(56).EQ.1) THEN
26964           IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
26965           IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
26966           IF(MSTP(57).EQ.0) Q2MX=P2MX
26967           P2=0D0
26968           IF(VINT(120).LT.0D0) P2=VINT(120)**2
26969           CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26970           DO 180 KFL=-6,6
26971             XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
26972   180     CONTINUE
26973           VINT(231)=P2MX
26974         ELSEIF(MSTP(56).EQ.2) THEN
26975           IF(MSTP(57).EQ.0) Q2MX=P2MX
26976           CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
26977           DO 190 KFL=-6,6
26978             XPQ(KFL)=XPGA(KFL)
26979   190     CONTINUE
26980           VINT(231)=P2MX
26981         ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
26982           IF(MSTP(57).EQ.0) Q2MX=P2MX
26983           CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
26984           DO 200 KFL=-6,6
26985             XPQ(KFL)=XPGA(KFL)
26986   200     CONTINUE
26987           VINT(231)=P2MX
26988         ELSE
26989   210     RKF=11D0*PYR(0)
26990           KFR=1
26991           IF(RKF.GT.1D0) KFR=2
26992           IF(RKF.GT.5D0) KFR=3
26993           IF(RKF.GT.6D0) KFR=4
26994           IF(RKF.GT.10D0) KFR=5
26995           IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
26996           IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
26997           IF(MSTP(57).EQ.0) Q2MX=P2MX
26998           CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
26999           DO 220 KFL=-6,6
27000             XPQ(KFL)=XPGA(KFL)
27001   220     CONTINUE
27002           VINT(231)=P2MX
27003         ENDIF
27004
27005 C...Proton parton distribution call.
27006       ELSE
27007         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27008           CALL PYPDPR(X,Q2,XPPR)
27009           DO 230 KFL=-6,6
27010             XPQ(KFL)=XPPR(KFL)
27011   230     CONTINUE
27012         ELSEIF(MSTP(52).EQ.2) THEN
27013 C...Call PDFLIB parton distributions.
27014           PARM(1)='NPTYPE'
27015           VALUE(1)=1
27016           PARM(2)='NGROUP'
27017           VALUE(2)=MSTP(51)/1000
27018           PARM(3)='NSET'
27019           VALUE(3)=MOD(MSTP(51),1000)
27020           IF(MINT(93).NE.1000000+MSTP(51)) THEN
27021 C .... ALICE
27022             CALL PDFSET_ALICE(PARM,VALUE)
27023             MINT(93)=1000000+MSTP(51)
27024           ENDIF
27025           XX=X
27026           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27027           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27028 C .... ALICE
27029           CALL STRUCTM_ALICE
27030      +    (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27031           VINT(231)=Q2MIN
27032           XPQ(0)=GLU
27033           XPQ(1)=DNV+DSEA
27034           XPQ(-1)=DSEA
27035           XPQ(2)=UPV+USEA
27036           XPQ(-2)=USEA
27037           XPQ(3)=STR
27038           XPQ(-3)=STR
27039           XPQ(4)=CHM
27040           XPQ(-4)=CHM
27041           XPQ(5)=BOT
27042           XPQ(-5)=BOT
27043           XPQ(6)=TOP
27044           XPQ(-6)=TOP
27045         ELSE
27046           WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27047         ENDIF
27048       ENDIF
27049
27050 C...Isospin average for pi0/gammaVDM.
27051       IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27052         IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27053           XPV=XPQ(2)-XPQ(1)
27054           XPQ(2)=XPQ(1)
27055           XPQ(-2)=XPQ(-1)
27056         ELSE
27057           XPS=0.5D0*(XPQ(1)+XPQ(-2))
27058           XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27059           XPQ(2)=XPS
27060           XPQ(-1)=XPS
27061         ENDIF
27062         IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
27063           XPQ(1)=XPQ(1)+0.2D0*XPV
27064           XPQ(-1)=XPQ(-1)+0.2D0*XPV
27065           XPQ(2)=XPQ(2)+0.8D0*XPV
27066           XPQ(-2)=XPQ(-2)+0.8D0*XPV
27067         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
27068           XPQ(3)=XPQ(3)+XPV
27069           XPQ(-3)=XPQ(-3)+XPV
27070         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
27071           XPQ(4)=XPQ(4)+XPV
27072           XPQ(-4)=XPQ(-4)+XPV
27073           IF(MSTP(55).GE.9) THEN
27074             DO 240 KFL=-6,6
27075               XPQ(KFL)=0D0
27076   240       CONTINUE
27077           ENDIF
27078         ELSE
27079           XPQ(1)=XPQ(1)+0.5D0*XPV
27080           XPQ(-1)=XPQ(-1)+0.5D0*XPV
27081           XPQ(2)=XPQ(2)+0.5D0*XPV
27082           XPQ(-2)=XPQ(-2)+0.5D0*XPV
27083         ENDIF
27084
27085 C...Rescale for gammaVDM by effective gamma -> rho coupling.
27086 C+++Do not rescale?
27087         IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
27088      &  .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
27089           DO 250 KFL=-6,6
27090             XPQ(KFL)=VINT(281)*XPQ(KFL)
27091   250     CONTINUE
27092           VINT(232)=VINT(281)*XPV
27093         ENDIF
27094
27095 C...Simple recipes for kaons.
27096       ELSEIF(KFA.EQ.321) THEN
27097         XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
27098         XPQ(-1)=XPQ(1)
27099       ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
27100         XPS=0.5D0*(XPQ(1)+XPQ(-2))
27101         XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27102         XPQ(2)=XPS
27103         XPQ(-1)=XPS
27104         XPQ(1)=XPQ(1)+0.5D0*XPV
27105         XPQ(-1)=XPQ(-1)+0.5D0*XPV
27106         XPQ(3)=XPQ(3)+0.5D0*XPV
27107         XPQ(-3)=XPQ(-3)+0.5D0*XPV
27108
27109 C...Isospin conjugation for neutron.
27110       ELSEIF(KFA.EQ.2112) THEN
27111         XPS=XPQ(1)
27112         XPQ(1)=XPQ(2)
27113         XPQ(2)=XPS
27114         XPS=XPQ(-1)
27115         XPQ(-1)=XPQ(-2)
27116         XPQ(-2)=XPS
27117
27118 C...Simple recipes for hyperon (average valence parton distribution).
27119       ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
27120      &  .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
27121         XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
27122         XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
27123         XPQ(1)=XPSEA
27124         XPQ(2)=XPSEA
27125         XPQ(-1)=XPSEA
27126         XPQ(-2)=XPSEA
27127         XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
27128         XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
27129         XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
27130       ENDIF
27131
27132 C...Charge conjugation for antiparticle.
27133       IF(KF.LT.0) THEN
27134         DO 260 KFL=1,25
27135           IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
27136           XPS=XPQ(KFL)
27137           XPQ(KFL)=XPQ(-KFL)
27138           XPQ(-KFL)=XPS
27139   260   CONTINUE
27140       ENDIF
27141
27142 C...Allow gluon also in position 21.
27143       XPQ(21)=XPQ(0)
27144
27145 C...Check positivity and reset above maximum allowed flavour.
27146       DO 270 KFL=-25,25
27147         XPQ(KFL)=MAX(0D0,XPQ(KFL))
27148         IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
27149   270 CONTINUE
27150
27151 C...Formats for error printouts.
27152  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27153  5100 FORMAT(' Error: illegal particle code for parton distribution;',
27154      &' KF =',I5)
27155  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
27156      &3I5)
27157
27158       RETURN
27159       END
27160
27161 C*********************************************************************
27162
27163 C...PYPDFL
27164 C...Gives proton parton distribution at small x and/or Q^2 according to
27165 C...correct limiting behaviour.
27166
27167       SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
27168
27169 C...Double precision and integer declarations.
27170       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27171       IMPLICIT INTEGER(I-N)
27172       INTEGER PYK,PYCHGE,PYCOMP
27173 C...Commonblocks.
27174       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27175       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27176       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27177       COMMON/PYINT1/MINT(400),VINT(400)
27178       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27179 C...Local arrays.
27180       DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
27181       DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
27182
27183 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
27184       MINT(92)=0
27185       KFA=IABS(KF)
27186       IACC=0
27187       IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
27188       IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
27189       IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
27190       IF(IACC.EQ.0) THEN
27191         CALL PYPDFU(KF,X,Q2,XPQ)
27192         RETURN
27193       ENDIF
27194
27195 C...Reset. Check x.
27196       DO 100 KFL=-25,25
27197         XPQ(KFL)=0D0
27198   100 CONTINUE
27199       IF(X.LE.0D0.OR.X.GE.1D0) THEN
27200         WRITE(MSTU(11),5000) X
27201         RETURN
27202       ENDIF
27203
27204 C...Define valence content.
27205       KFC=KF
27206       NV1=2
27207       NV2=1
27208       IF(KF.EQ.2212) THEN
27209         KFV1=2
27210         KFV2=1
27211       ELSEIF(KF.EQ.-2212) THEN
27212         KFV1=-2
27213         KFV2=-1
27214       ELSEIF(KF.EQ.2112) THEN
27215         KFV1=1
27216         KFV2=2
27217       ELSEIF(KF.EQ.-2112) THEN
27218         KFV1=-1
27219         KFV2=-2
27220       ELSEIF(KF.EQ.211) THEN
27221         NV1=1
27222         KFV1=2
27223         KFV2=-1
27224       ELSEIF(KF.EQ.-211) THEN
27225         NV1=1
27226         KFV1=-2
27227         KFV2=1
27228       ELSEIF(MINT(105).LE.223) THEN
27229         KFV1=1
27230         WTV1=0.2D0
27231         KFV2=2
27232         WTV2=0.8D0
27233       ELSEIF(MINT(105).EQ.333) THEN
27234         KFV1=3
27235         WTV1=1.0D0
27236         KFV2=1
27237         WTV2=0.0D0
27238       ELSEIF(MINT(105).EQ.443) THEN
27239         KFV1=4
27240         WTV1=1.0D0
27241         KFV2=1
27242         WTV2=0.0D0
27243       ENDIF
27244
27245 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
27246       CALL PYPDFU(KFC,X,Q2,XPA)
27247       Q2MN=MAX(3D0,VINT(231))
27248       Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
27249       XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
27250
27251 C...Large Q2 and large x: naive call is enough.
27252       IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
27253         DO 110 KFL=-25,25
27254           XPQ(KFL)=XPA(KFL)
27255   110   CONTINUE
27256         MINT(92)=1
27257
27258 C...Small Q2 and large x: dampen boundary value.
27259       ELSEIF(X.GT.XMN) THEN
27260
27261 C...Evaluate at boundary and define dampening factors.
27262         CALL PYPDFU(KFC,X,Q2MN,XPA)
27263         FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
27264         FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
27265
27266 C...Separate valence and sea parts of parton distribution.
27267         IF(KFA.NE.22) THEN
27268           XFV1=XPA(KFV1)-XPA(-KFV1)
27269           XPA(KFV1)=XPA(-KFV1)
27270           XFV2=XPA(KFV2)-XPA(-KFV2)
27271           XPA(KFV2)=XPA(-KFV2)
27272         ELSE
27273           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27274           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27275           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27276           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27277         ENDIF
27278
27279 C...Dampen valence and sea separately. Put back together.
27280         DO 120 KFL=-25,25
27281           XPQ(KFL)=FS*XPA(KFL)
27282   120   CONTINUE
27283         IF(KFA.NE.22) THEN
27284           XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
27285           XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
27286         ELSE
27287           XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
27288           XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
27289           XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
27290           XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
27291         ENDIF
27292         MINT(92)=2
27293
27294 C...Large Q2 and small x: interpolate behaviour.
27295       ELSEIF(Q2.GT.Q2MN) THEN
27296
27297 C...Evaluate at extremes and define coefficients for interpolation.
27298         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27299         VI232A=VINT(232)
27300         CALL PYPDFU(KFC,X,Q2B,XPB)
27301         VI232B=VINT(232)
27302         FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
27303         FVA=(X/XMN)**0.45D0*FLA
27304         FSA=(X/XMN)**(-0.08D0)*FLA
27305         FB=1D0-FLA
27306
27307 C...Separate valence and sea parts of parton distribution.
27308         IF(KFA.NE.22) THEN
27309           XFVA1=XPA(KFV1)-XPA(-KFV1)
27310           XPA(KFV1)=XPA(-KFV1)
27311           XFVA2=XPA(KFV2)-XPA(-KFV2)
27312           XPA(KFV2)=XPA(-KFV2)
27313           XFVB1=XPB(KFV1)-XPB(-KFV1)
27314           XPB(KFV1)=XPB(-KFV1)
27315           XFVB2=XPB(KFV2)-XPB(-KFV2)
27316           XPB(KFV2)=XPB(-KFV2)
27317         ELSE
27318           XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
27319           XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
27320           XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
27321           XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
27322           XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
27323           XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
27324           XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
27325           XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
27326         ENDIF
27327
27328 C...Interpolate for valence and sea. Put back together.
27329         DO 130 KFL=-25,25
27330           XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
27331   130   CONTINUE
27332         IF(KFA.NE.22) THEN
27333           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
27334           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
27335         ELSE
27336           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27337           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27338           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27339           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27340         ENDIF
27341         MINT(92)=3
27342
27343 C...Small Q2 and small x: dampen boundary value and add term.
27344       ELSE
27345
27346 C...Evaluate at boundary and define dampening factors.
27347         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27348         FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
27349         FA=1D0-FB
27350         FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
27351         FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
27352         FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
27353         FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
27354         FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
27355         FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
27356
27357 C...Separate valence and sea parts of parton distribution.
27358         IF(KFA.NE.22) THEN
27359           XFV1=XPA(KFV1)-XPA(-KFV1)
27360           XPA(KFV1)=XPA(-KFV1)
27361           XFV2=XPA(KFV2)-XPA(-KFV2)
27362           XPA(KFV2)=XPA(-KFV2)
27363         ELSE
27364           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27365           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27366           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27367           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27368         ENDIF
27369
27370 C...Dampen valence and sea separately. Add constant terms.
27371 C...Put back together.
27372         DO 140 KFL=-25,25
27373           XPQ(KFL)=FSA*XPA(KFL)
27374   140   CONTINUE
27375         IF(KFA.NE.22) THEN
27376           DO 150 KFL=-3,3
27377             XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
27378   150     CONTINUE
27379           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
27380           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
27381         ELSE
27382           DO 160 KFL=-3,3
27383             XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
27384   160     CONTINUE
27385           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27386           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27387           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27388           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27389         ENDIF
27390         XPQ(21)=XPQ(0)
27391         MINT(92)=4
27392       ENDIF
27393
27394 C...Format for error printout.
27395  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27396
27397       RETURN
27398       END
27399
27400 C*********************************************************************
27401
27402 C...PYPDEL
27403 C...Gives electron (or muon, or tau) parton distribution.
27404
27405       SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
27406
27407 C...Double precision and integer declarations.
27408       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27409       IMPLICIT INTEGER(I-N)
27410       INTEGER PYK,PYCHGE,PYCOMP
27411 C...Commonblocks.
27412       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27413       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27414       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27415       COMMON/PYINT1/MINT(400),VINT(400)
27416       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27417 C...Local arrays.
27418       DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
27419
27420 C...Interface to PDFLIB.
27421       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
27422       SAVE /W50513/
27423       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27424      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27425       CHARACTER*20 PARM(20)
27426       DATA VALUE/20*0D0/,PARM/20*' '/
27427
27428 C...Some common constants.
27429       DO 100 KFL=-25,25
27430         XPEL(KFL)=0D0
27431   100 CONTINUE
27432       AEM=PARU(101)
27433       PME=PMAS(11,1)
27434       IF(KFA.EQ.13) PME=PMAS(13,1)
27435       IF(KFA.EQ.15) PME=PMAS(15,1)
27436       XL=LOG(MAX(1D-10,X))
27437       X1L=LOG(MAX(1D-10,1D0-X))
27438       HLE=LOG(MAX(3D0,Q2/PME**2))
27439       HBE2=(AEM/PARU(1))*(HLE-1D0)
27440
27441 C...Electron inside electron, see R. Kleiss et al., in Z physics at
27442 C...LEP 1, CERN 89-08, p. 34
27443       IF(MSTP(59).LE.1) THEN
27444         HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
27445      &  (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
27446         HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
27447      &  0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
27448      &  4D0*XL/(1D0-X)-5D0-X)
27449       ELSE
27450         HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
27451      &  PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
27452      &  (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
27453       ENDIF
27454 C...Zero distribution for very large x and rescale it for intermediate.
27455       IF(X.GT.1D0-1D-10) THEN
27456         HEE=0D0
27457       ELSEIF(X.GT.1D0-1D-7) THEN
27458         HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
27459       ENDIF
27460       XPEL(KFA)=X*HEE
27461
27462 C...Photon and (transverse) W- inside electron.
27463       AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
27464       IF(MSTP(13).LE.1) THEN
27465         HLG=HLE
27466       ELSE
27467         HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
27468       ENDIF
27469       XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
27470       HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
27471       XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
27472
27473 C...Electron or positron inside photon inside electron.
27474       IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
27475         XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
27476      &  2D0*X*(1D0+X)*XL)
27477         XPEL(11)=XPEL(11)+XFSEA
27478         XPEL(-11)=XFSEA
27479
27480 C...Initialize PDFLIB photon parton distributions.
27481         IF(MSTP(56).EQ.2) THEN
27482           PARM(1)='NPTYPE'
27483           VALUE(1)=3
27484           PARM(2)='NGROUP'
27485           VALUE(2)=MSTP(55)/1000
27486           PARM(3)='NSET'
27487           VALUE(3)=MOD(MSTP(55),1000)
27488           IF(MINT(93).NE.3000000+MSTP(55)) THEN
27489             CALL PDFSET(PARM,VALUE)
27490             MINT(93)=3000000+MSTP(55)
27491           ENDIF
27492         ENDIF
27493
27494 C...Quarks and gluons inside photon inside electron:
27495 C...numerical convolution required.
27496         DO 110 KFL=0,6
27497           SXP(KFL)=0D0
27498   110   CONTINUE
27499         SUMXPP=0D0
27500         ITER=-1
27501   120   ITER=ITER+1
27502         SUMXP=SUMXPP
27503         NSTP=2**(ITER-1)
27504         IF(ITER.EQ.0) NSTP=2
27505         DO 130 KFL=0,6
27506           SXP(KFL)=0.5D0*SXP(KFL)
27507   130   CONTINUE
27508         WTSTP=0.5D0/NSTP
27509         IF(ITER.EQ.0) WTSTP=0.5D0
27510 C...Pick grid of x_{gamma} values logarithmically even.
27511         DO 150 ISTP=1,NSTP
27512           IF(ITER.EQ.0) THEN
27513             XLE=XL*(ISTP-1)
27514           ELSE
27515             XLE=XL*(ISTP-0.5D0)/NSTP
27516           ENDIF
27517           XE=MIN(1D0-1D-10,EXP(XLE))
27518           XG=MIN(1D0-1D-10,X/XE)
27519 C...Evaluate photon inside electron parton distribution for convolution.
27520           XPGP=1D0+(1D0-XE)**2
27521           IF(MSTP(13).LE.1) THEN
27522             XPGP=XPGP*HLE
27523           ELSE
27524             XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
27525           ENDIF
27526 C...Evaluate photon parton distributions for convolution.
27527           IF(MSTP(56).EQ.1) THEN
27528             CALL PYPDGA(XG,Q2,XPGA)
27529             DO 140 KFL=0,5
27530               SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
27531   140       CONTINUE
27532           ELSEIF(MSTP(56).EQ.2) THEN
27533 C...Call PDFLIB parton distributions.
27534             XX=XG
27535             QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27536             IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27537             CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27538             SXP(0)=SXP(0)+WTSTP*XPGP*GLU
27539             SXP(1)=SXP(1)+WTSTP*XPGP*DNV
27540             SXP(2)=SXP(2)+WTSTP*XPGP*UPV
27541             SXP(3)=SXP(3)+WTSTP*XPGP*STR
27542             SXP(4)=SXP(4)+WTSTP*XPGP*CHM
27543             SXP(5)=SXP(5)+WTSTP*XPGP*BOT
27544             SXP(6)=SXP(6)+WTSTP*XPGP*TOP
27545           ENDIF
27546   150   CONTINUE
27547         SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
27548         IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
27549      &  PARP(14)*(SUMXPP+SUMXP))) GOTO 120
27550
27551 C...Put convolution into output arrays.
27552         FCONV=AEMP*(-XL)
27553         XPEL(0)=FCONV*SXP(0)
27554         DO 160 KFL=1,6
27555           XPEL(KFL)=FCONV*SXP(KFL)
27556           XPEL(-KFL)=XPEL(KFL)
27557   160   CONTINUE
27558       ENDIF
27559
27560       RETURN
27561       END
27562
27563 C*********************************************************************
27564
27565 C...PYPDGA
27566 C...Gives photon parton distribution.
27567
27568       SUBROUTINE PYPDGA(X,Q2,XPGA)
27569
27570 C...Double precision and integer declarations.
27571       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27572       IMPLICIT INTEGER(I-N)
27573       INTEGER PYK,PYCHGE,PYCOMP
27574 C...Commonblocks.
27575       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27576       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27577       COMMON/PYINT1/MINT(400),VINT(400)
27578       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
27579 C...Local arrays.
27580       DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
27581      &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
27582      &DGCS(4,3),DGDS(4,3),DGES(4,3)
27583
27584 C...The following data lines are coefficients needed in the
27585 C...Drees and Grassie photon parton distribution parametrization.
27586       DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
27587      &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
27588       DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
27589      &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
27590       DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
27591      &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
27592       DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
27593      &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
27594       DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
27595      &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
27596       DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
27597      &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
27598       DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
27599      &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
27600       DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
27601      &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
27602       DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
27603      &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
27604       DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
27605      &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
27606       DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
27607      &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
27608       DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
27609      &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
27610       DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
27611      &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
27612
27613 C...Photon parton distribution from Drees and Grassie.
27614 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
27615       DO 100 KFL=-6,6
27616         XPGA(KFL)=0D0
27617   100 CONTINUE
27618       VINT(231)=1D0
27619       IF(MSTP(57).LE.0) THEN
27620         T=LOG(1D0/0.16D0)
27621       ELSE
27622         T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
27623       ENDIF
27624       X1=1D0-X
27625       NF=3
27626       IF(Q2.GT.25D0) NF=4
27627       IF(Q2.GT.300D0) NF=5
27628       NFE=NF-2
27629       AEM=PARU(101)
27630
27631 C...Evaluate gluon content.
27632       DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
27633       DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
27634       DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
27635       XPGL=DGA*X**DGB*X1**DGC
27636
27637 C...Evaluate up- and down-type quark content.
27638       DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
27639       DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
27640       DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
27641       DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
27642       DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
27643       XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27644       DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
27645       DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
27646       DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
27647       DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
27648       DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
27649       DGF=9D0
27650       IF(NF.EQ.4) DGF=10D0
27651       IF(NF.EQ.5) DGF=55D0/6D0
27652       XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27653       IF(NF.LE.3) THEN
27654         XPQU=(XPQS+9D0*XPQN)/6D0
27655         XPQD=(XPQS-4.5D0*XPQN)/6D0
27656       ELSEIF(NF.EQ.4) THEN
27657         XPQU=(XPQS+6D0*XPQN)/8D0
27658         XPQD=(XPQS-6D0*XPQN)/8D0
27659       ELSE
27660         XPQU=(XPQS+7.5D0*XPQN)/10D0
27661         XPQD=(XPQS-5D0*XPQN)/10D0
27662       ENDIF
27663
27664 C...Put into output arrays.
27665       XPGA(0)=AEM*XPGL
27666       XPGA(1)=AEM*XPQD
27667       XPGA(2)=AEM*XPQU
27668       XPGA(3)=AEM*XPQD
27669       IF(NF.GE.4) XPGA(4)=AEM*XPQU
27670       IF(NF.GE.5) XPGA(5)=AEM*XPQD
27671       DO 110 KFL=1,6
27672         XPGA(-KFL)=XPGA(KFL)
27673   110 CONTINUE
27674
27675       RETURN
27676       END
27677
27678 C*********************************************************************
27679
27680 C...PYGGAM
27681 C...Constructs the F2 and parton distributions of the photon
27682 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
27683 C...For F2, c and b are included by the Bethe-Heitler formula;
27684 C...in the 'MSbar' scheme additionally a Cgamma term is added.
27685 C...Contains the SaS sets 1D, 1M, 2D and 2M.
27686 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27687
27688       SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
27689
27690 C...Double precision and integer declarations.
27691       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27692       IMPLICIT INTEGER(I-N)
27693       INTEGER PYK,PYCHGE,PYCOMP
27694 C...Commonblocks.
27695       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27696      &XPDIR(-6:6)
27697       COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
27698       SAVE /PYINT8/,/PYINT9/
27699 C...Local arrays.
27700       DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
27701 C...Charm and bottom masses (low to compensate for J/psi etc.).
27702       DATA PMC/1.3D0/, PMB/4.6D0/
27703 C...alpha_em and alpha_em/(2*pi).
27704       DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
27705 C...Lambda value for 4 flavours.
27706       DATA ALAM/0.20D0/
27707 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
27708       DATA FRACU/0.8D0/
27709 C...VMD couplings f_V**2/(4*pi).
27710       DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
27711 C...Masses for rho (=omega) and phi.
27712       DATA PMRHO/0.770D0/, PMPHI/1.020D0/
27713 C...Number of points in integration for IP2=1.
27714       DATA NSTEP/100/
27715
27716 C...Reset output.
27717       F2GM=0D0
27718       DO 100 KFL=-6,6
27719         XPDFGM(KFL)=0D0
27720         XPVMD(KFL)=0D0
27721         XPANL(KFL)=0D0
27722         XPANH(KFL)=0D0
27723         XPBEH(KFL)=0D0
27724         XPDIR(KFL)=0D0
27725         VXPVMD(KFL)=0D0
27726         VXPANL(KFL)=0D0
27727         VXPANH(KFL)=0D0
27728         VXPDGM(KFL)=0D0
27729   100 CONTINUE
27730
27731 C...Set Q0 cut-off parameter as function of set used.
27732       IF(ISET.LE.2) THEN
27733         Q0=0.6D0
27734       ELSE
27735         Q0=2D0
27736       ENDIF
27737       Q02=Q0**2
27738
27739 C...Scale choice for off-shell photon; common factors.
27740       Q2A=Q2
27741       FACNOR=1D0
27742       IF(IP2.EQ.1) THEN
27743         P2MX=P2+Q02
27744         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27745         FACNOR=LOG(Q2/Q02)/NSTEP
27746       ELSEIF(IP2.EQ.2) THEN
27747         P2MX=MAX(P2,Q02)
27748       ELSEIF(IP2.EQ.3) THEN
27749         P2MX=P2+Q02
27750         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27751       ELSEIF(IP2.EQ.4) THEN
27752         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27753      &  ((Q2+P2)*(Q02+P2)))
27754       ELSEIF(IP2.EQ.5) THEN
27755         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27756      &  ((Q2+P2)*(Q02+P2)))
27757         P2MX=Q0*SQRT(P2MXA)
27758         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
27759       ELSEIF(IP2.EQ.6) THEN
27760         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27761      &  ((Q2+P2)*(Q02+P2)))
27762         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27763       ELSE
27764         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27765      &  ((Q2+P2)*(Q02+P2)))
27766         P2MX=Q0*SQRT(P2MXA)
27767         P2MXB=P2MX
27768         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27769         P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
27770         IF(ABS(Q2-Q02).GT.1D-6) THEN
27771           FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
27772         ELSEIF(P2.LT.Q02) THEN
27773           FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
27774         ELSE
27775           FACNOR=1D0
27776         ENDIF
27777       ENDIF
27778
27779 C...Call VMD parametrization for d quark and use to give rho, omega,
27780 C...phi. Note dipole dampening for off-shell photon.
27781       CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27782       XFVAL=VXPGA(1)
27783       XPGA(1)=XPGA(2)
27784       XPGA(-1)=XPGA(-2)
27785       FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
27786       FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
27787       DO 110 KFL=-5,5
27788         XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
27789   110 CONTINUE
27790       XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
27791       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
27792       XPVMD(3)=XPVMD(3)+FACS*XFVAL
27793       XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
27794       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
27795       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
27796       VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
27797       VXPVMD(2)=FRACU*FACUD*XFVAL
27798       VXPVMD(3)=FACS*XFVAL
27799       VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
27800       VXPVMD(-2)=FRACU*FACUD*XFVAL
27801       VXPVMD(-3)=FACS*XFVAL
27802
27803       IF(IP2.NE.1) THEN
27804 C...Anomalous parametrizations for different strategies
27805 C...for off-shell photons; except full integration.
27806
27807 C...Call anomalous parametrization for d + u + s.
27808         CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27809         DO 120 KFL=-5,5
27810           XPANL(KFL)=FACNOR*XPGA(KFL)
27811           VXPANL(KFL)=FACNOR*VXPGA(KFL)
27812   120   CONTINUE
27813
27814 C...Call anomalous parametrization for c and b.
27815         CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27816         DO 130 KFL=-5,5
27817           XPANH(KFL)=FACNOR*XPGA(KFL)
27818           VXPANH(KFL)=FACNOR*VXPGA(KFL)
27819   130   CONTINUE
27820         CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27821         DO 140 KFL=-5,5
27822           XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
27823           VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
27824   140   CONTINUE
27825
27826       ELSE
27827 C...Special option: loop over flavours and integrate over k2.
27828         DO 170 KF=1,5
27829           DO 160 ISTEP=1,NSTEP
27830             Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
27831             IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
27832      &      (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
27833             CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
27834             FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
27835             IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
27836             IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
27837             DO 150 KFL=-5,5
27838               IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
27839               IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
27840               IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
27841               IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
27842   150       CONTINUE
27843   160     CONTINUE
27844   170   CONTINUE
27845       ENDIF
27846
27847 C...Call Bethe-Heitler term expression for charm and bottom.
27848       CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
27849       XPBEH(4)=XPBH
27850       XPBEH(-4)=XPBH
27851       CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
27852       XPBEH(5)=XPBH
27853       XPBEH(-5)=XPBH
27854
27855 C...For MSbar subtraction call C^gamma term expression for d, u, s.
27856       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
27857         CALL PYGDIR(X,Q2,P2,Q02,XPGA)
27858         DO 180 KFL=-5,5
27859           XPDIR(KFL)=XPGA(KFL)
27860   180   CONTINUE
27861       ENDIF
27862
27863 C...Store result in output array.
27864       DO 190 KFL=-5,5
27865         CHSQ=1D0/9D0
27866         IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
27867         XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27868         IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
27869         XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
27870         VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
27871   190 CONTINUE
27872
27873       RETURN
27874       END
27875
27876 C*********************************************************************
27877
27878 C...PYGVMD
27879 C...Evaluates the VMD parton distributions of a photon,
27880 C...evolved homogeneously from an initial scale P2 to Q2.
27881 C...Does not include dipole suppression factor.
27882 C...ISET is parton distribution set, see above;
27883 C...additionally ISET=0 is used for the evolution of an anomalous photon
27884 C...which branched at a scale P2 and then evolved homogeneously to Q2.
27885 C...ALAM is the 4-flavour Lambda, which is automatically converted
27886 C...to 3- and 5-flavour equivalents as needed.
27887 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27888
27889       SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
27890
27891 C...Double precision and integer declarations.
27892       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27893       IMPLICIT INTEGER(I-N)
27894       INTEGER PYK,PYCHGE,PYCOMP
27895 C...Local arrays and data.
27896       DIMENSION XPGA(-6:6), VXPGA(-6:6)
27897       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
27898
27899 C...Reset output.
27900       DO 100 KFL=-6,6
27901         XPGA(KFL)=0D0
27902         VXPGA(KFL)=0D0
27903   100 CONTINUE
27904       KFA=IABS(KF)
27905
27906 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
27907       ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
27908       ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
27909       P2EFF=MAX(P2,1.2D0*ALAM3**2)
27910       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
27911       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
27912       Q2EFF=MAX(Q2,P2EFF)
27913
27914 C...Find number of flavours at lower and upper scale.
27915       NFP=4
27916       IF(P2EFF.LT.PMC**2) NFP=3
27917       IF(P2EFF.GT.PMB**2) NFP=5
27918       NFQ=4
27919       IF(Q2EFF.LT.PMC**2) NFQ=3
27920       IF(Q2EFF.GT.PMB**2) NFQ=5
27921
27922 C...Find s as sum of 3-, 4- and 5-flavour parts.
27923       S=0D0
27924       IF(NFP.EQ.3) THEN
27925         Q2DIV=PMC**2
27926         IF(NFQ.EQ.3) Q2DIV=Q2EFF
27927         S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
27928       ENDIF
27929       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
27930         P2DIV=P2EFF
27931         IF(NFP.EQ.3) P2DIV=PMC**2
27932         Q2DIV=Q2EFF
27933         IF(NFQ.EQ.5) Q2DIV=PMB**2
27934         S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
27935       ENDIF
27936       IF(NFQ.EQ.5) THEN
27937         P2DIV=PMB**2
27938         IF(NFP.EQ.5) P2DIV=P2EFF
27939         S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
27940       ENDIF
27941
27942 C...Calculate frequent combinations of x and s.
27943       X1=1D0-X
27944       XL=-LOG(X)
27945       S2=S**2
27946       S3=S**3
27947       S4=S**4
27948
27949 C...Evaluate homogeneous anomalous parton distributions below or
27950 C...above threshold.
27951       IF(ISET.EQ.0) THEN
27952         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27953      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27954           XVAL = X * 1.5D0 * (X**2+X1**2)
27955           XGLU = 0D0
27956           XSEA = 0D0
27957         ELSE
27958           XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
27959      &    (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
27960      &    5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
27961      &    X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
27962           XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
27963      &    X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
27964      &    ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
27965           XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
27966      &    X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
27967      &    ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
27968      &    (2D0*X-1D0)*X*XL**2)
27969         ENDIF
27970
27971 C...Evaluate set 1D parton distributions below or above threshold.
27972       ELSEIF(ISET.EQ.1) THEN
27973         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27974      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27975           XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
27976           XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
27977           XSEA = 0.100D0 * X1**3.76D0
27978         ELSE
27979           XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
27980      &    X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
27981           XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
27982      &    X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
27983      &    XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
27984      &    X**0.40D0 * X1**(1.76D0+3D0*S)
27985           XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
27986      &    (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
27987      &    X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
27988           XSEA0 = 0.100D0 * X1**3.76D0
27989         ENDIF
27990
27991 C...Evaluate set 1M parton distributions below or above threshold.
27992       ELSEIF(ISET.EQ.2) THEN
27993         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27994      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27995           XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
27996           XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
27997           XSEA = 0D0
27998         ELSE
27999           XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28000      &    X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28001           XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28002      &    EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28003      &    X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28004      &    EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28005           XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28006      &    X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28007      &    XL**(2.8D0*S)
28008           XSEA0 = 0D0
28009         ENDIF
28010
28011 C...Evaluate set 2D parton distributions below or above threshold.
28012       ELSEIF(ISET.EQ.3) THEN
28013         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28014      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28015           XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28016           XGLU = 1.925D0 * X1**2
28017           XSEA = 0.242D0 * X1**4
28018         ELSE
28019           XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28020      &    X**(0.46D0+0.25D0*S) *
28021      &    X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28022      &    (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28023           XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28024      &    EXP(-18.67D0*S) *
28025      &    X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28026      &    * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28027      &    XL**(9.3D0*S/(1D0+1.7D0*S))
28028           XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28029      &    (1D0-0.607D0*S+21.95D0*S2) *
28030      &    X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28031           XSEA0 = 0.242D0 * X1**4
28032         ENDIF
28033
28034 C...Evaluate set 2M parton distributions below or above threshold.
28035       ELSEIF(ISET.EQ.4) THEN
28036         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28037      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28038           XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28039           XGLU = 1.808D0 * X1**2
28040           XSEA = 0.209D0 * X1**4
28041         ELSE
28042           XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
28043      &    X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
28044      &    X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
28045      &    XL**(5.15D0*S/(1D0+2D0*S)) +
28046      &    (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
28047           XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
28048      &    X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
28049      &    X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
28050      &    XL**(10.9D0*S/(1D0+2.5D0*S))
28051           XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
28052      &    X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
28053      &    X1**(4D0+S) * XL**(0.45D0*S)
28054           XSEA0 = 0.209D0 * X1**4
28055         ENDIF
28056       ENDIF
28057
28058 C...Threshold factors for c and b sea.
28059       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28060       XCHM=0D0
28061       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28062         SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28063         IF(ISET.EQ.0) THEN
28064           XCHM=XSEA*(1D0-(SCH/SLL)**2)
28065         ELSE
28066           XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
28067         ENDIF
28068       ENDIF
28069       XBOT=0D0
28070       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28071         SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28072         IF(ISET.EQ.0) THEN
28073           XBOT=XSEA*(1D0-(SBT/SLL)**2)
28074         ELSE
28075           XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
28076         ENDIF
28077       ENDIF
28078
28079 C...Fill parton distributions.
28080       XPGA(0)=XGLU
28081       XPGA(1)=XSEA
28082       XPGA(2)=XSEA
28083       XPGA(3)=XSEA
28084       XPGA(4)=XCHM
28085       XPGA(5)=XBOT
28086       XPGA(KFA)=XPGA(KFA)+XVAL
28087       DO 110 KFL=1,5
28088         XPGA(-KFL)=XPGA(KFL)
28089   110 CONTINUE
28090       VXPGA(KFA)=XVAL
28091       VXPGA(-KFA)=XVAL
28092
28093       RETURN
28094       END
28095
28096 C*********************************************************************
28097
28098 C...PYGANO
28099 C...Evaluates the parton distributions of the anomalous photon,
28100 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
28101 C...KF=0 gives the sum over (up to) 5 flavours,
28102 C...KF<0 limits to flavours up to abs(KF),
28103 C...KF>0 is for flavour KF only.
28104 C...ALAM is the 4-flavour Lambda, which is automatically converted
28105 C...to 3- and 5-flavour equivalents as needed.
28106 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28107
28108       SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28109
28110 C...Double precision and integer declarations.
28111       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28112       IMPLICIT INTEGER(I-N)
28113       INTEGER PYK,PYCHGE,PYCOMP
28114 C...Local arrays and data.
28115       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
28116       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28117
28118 C...Reset output.
28119       DO 100 KFL=-6,6
28120         XPGA(KFL)=0D0
28121         VXPGA(KFL)=0D0
28122   100 CONTINUE
28123       IF(Q2.LE.P2) RETURN
28124       KFA=IABS(KF)
28125
28126 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28127       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
28128       ALAMSQ(4)=ALAM**2
28129       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
28130       P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
28131       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28132       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28133       Q2EFF=MAX(Q2,P2EFF)
28134       XL=-LOG(X)
28135
28136 C...Find number of flavours at lower and upper scale.
28137       NFP=4
28138       IF(P2EFF.LT.PMC**2) NFP=3
28139       IF(P2EFF.GT.PMB**2) NFP=5
28140       NFQ=4
28141       IF(Q2EFF.LT.PMC**2) NFQ=3
28142       IF(Q2EFF.GT.PMB**2) NFQ=5
28143
28144 C...Define range of flavour loop.
28145       IF(KF.EQ.0) THEN
28146         KFLMN=1
28147         KFLMX=5
28148       ELSEIF(KF.LT.0) THEN
28149         KFLMN=1
28150         KFLMX=KFA
28151       ELSE
28152         KFLMN=KFA
28153         KFLMX=KFA
28154       ENDIF
28155
28156 C...Loop over flavours the photon can branch into.
28157       DO 110 KFL=KFLMN,KFLMX
28158
28159 C...Light flavours: calculate t range and (approximate) s range.
28160         IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
28161           TDIFF=LOG(Q2EFF/P2EFF)
28162           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28163      &    LOG(P2EFF/ALAMSQ(NFQ)))
28164           IF(NFQ.GT.NFP) THEN
28165             Q2DIV=PMB**2
28166             IF(NFQ.EQ.4) Q2DIV=PMC**2
28167             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28168      &      LOG(P2EFF/ALAMSQ(NFQ)))
28169             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28170      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
28171             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28172           ENDIF
28173           IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
28174             Q2DIV=PMC**2
28175             SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
28176      &      LOG(P2EFF/ALAMSQ(4)))
28177             SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
28178      &      LOG(P2EFF/ALAMSQ(3)))
28179             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
28180           ENDIF
28181
28182 C...u and s quark do not need a separate treatment when d has been done.
28183         ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
28184
28185 C...Charm: as above, but only include range above c threshold.
28186         ELSEIF(KFL.EQ.4) THEN
28187           IF(Q2.LE.PMC**2) GOTO 110
28188           P2EFF=MAX(P2EFF,PMC**2)
28189           Q2EFF=MAX(Q2EFF,P2EFF)
28190           TDIFF=LOG(Q2EFF/P2EFF)
28191           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28192      &    LOG(P2EFF/ALAMSQ(NFQ)))
28193           IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
28194             Q2DIV=PMB**2
28195             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28196      &      LOG(P2EFF/ALAMSQ(NFQ)))
28197             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28198      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
28199             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28200           ENDIF
28201
28202 C...Bottom: as above, but only include range above b threshold.
28203         ELSEIF(KFL.EQ.5) THEN
28204           IF(Q2.LE.PMB**2) GOTO 110
28205           P2EFF=MAX(P2EFF,PMB**2)
28206           Q2EFF=MAX(Q2,P2EFF)
28207           TDIFF=LOG(Q2EFF/P2EFF)
28208           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28209      &    LOG(P2EFF/ALAMSQ(NFQ)))
28210         ENDIF
28211
28212 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
28213         CHSQ=1D0/9D0
28214         IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
28215         FAC=AEM2PI*2D0*CHSQ*TDIFF
28216
28217 C...Evaluate parton distributions (normalized to unit momentum sum).
28218         IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
28219           XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
28220      &    (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
28221      &    1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
28222      &    X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
28223           XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
28224      &    X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
28225      &    ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
28226           XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
28227      &    X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
28228      &    ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
28229      &    (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
28230
28231 C...Threshold factors for c and b sea.
28232           SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28233           XCHM=0D0
28234           IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28235             SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28236             XCHM=XSEA*(1D0-(SCH/SLL)**3)
28237           ENDIF
28238           XBOT=0D0
28239           IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28240             SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28241             XBOT=XSEA*(1D0-(SBT/SLL)**3)
28242           ENDIF
28243         ENDIF
28244
28245 C...Add contribution of each valence flavour.
28246         XPGA(0)=XPGA(0)+FAC*XGLU
28247         XPGA(1)=XPGA(1)+FAC*XSEA
28248         XPGA(2)=XPGA(2)+FAC*XSEA
28249         XPGA(3)=XPGA(3)+FAC*XSEA
28250         XPGA(4)=XPGA(4)+FAC*XCHM
28251         XPGA(5)=XPGA(5)+FAC*XBOT
28252         XPGA(KFL)=XPGA(KFL)+FAC*XVAL
28253         VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
28254   110 CONTINUE
28255       DO 120 KFL=1,5
28256         XPGA(-KFL)=XPGA(KFL)
28257         VXPGA(-KFL)=VXPGA(KFL)
28258   120 CONTINUE
28259
28260       RETURN
28261       END
28262
28263 C*********************************************************************
28264
28265 C...PYGBEH
28266 C...Evaluates the Bethe-Heitler cross section for heavy flavour
28267 C...production.
28268 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28269
28270       SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
28271
28272 C...Double precision and integer declarations.
28273       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28274       IMPLICIT INTEGER(I-N)
28275       INTEGER PYK,PYCHGE,PYCOMP
28276
28277 C...Local data.
28278       DATA AEM2PI/0.0011614D0/
28279
28280 C...Reset output.
28281       XPBH=0D0
28282       SIGBH=0D0
28283
28284 C...Check kinematics limits.
28285       IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
28286       W2=Q2*(1D0-X)/X-P2
28287       BETA2=1D0-4D0*PM2/W2
28288       IF(BETA2.LT.1D-10) RETURN
28289       BETA=SQRT(BETA2)
28290       RMQ=4D0*PM2/Q2
28291
28292 C...Simple case: P2 = 0.
28293       IF(P2.LT.1D-4) THEN
28294         IF(BETA.LT.0.99D0) THEN
28295           XBL=LOG((1D0+BETA)/(1D0-BETA))
28296         ELSE
28297           XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
28298         ENDIF
28299         SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
28300      &  XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
28301
28302 C...Complicated case: P2 > 0, based on approximation of
28303 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
28304       ELSE
28305         RPQ=1D0-4D0*X**2*P2/Q2
28306         IF(RPQ.GT.1D-10) THEN
28307           RPBE=SQRT(RPQ*BETA2)
28308           IF(RPBE.LT.0.99D0) THEN
28309             XBL=LOG((1D0+RPBE)/(1D0-RPBE))
28310             XBI=2D0*RPBE/(1D0-RPBE**2)
28311           ELSE
28312             RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
28313             XBL=LOG((1D0+RPBE)**2/RPBESN)
28314             XBI=2D0*RPBE/RPBESN
28315           ENDIF
28316           SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
28317      &    XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
28318      &    XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
28319         ENDIF
28320       ENDIF
28321
28322 C...Multiply by charge-squared etc. to get parton distribution.
28323       CHSQ=1D0/9D0
28324       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
28325       XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
28326
28327       RETURN
28328       END
28329
28330 C*********************************************************************
28331
28332 C...PYGDIR
28333 C...Evaluates the direct contribution, i.e. the C^gamma term,
28334 C...as needed in MSbar parametrizations.
28335 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28336
28337       SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
28338
28339 C...Double precision and integer declarations.
28340       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28341       IMPLICIT INTEGER(I-N)
28342       INTEGER PYK,PYCHGE,PYCOMP
28343 C...Local array and data.
28344       DIMENSION XPGA(-6:6)
28345       DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
28346
28347 C...Reset output.
28348       DO 100 KFL=-6,6
28349         XPGA(KFL)=0D0
28350   100 CONTINUE
28351
28352 C...Evaluate common x-dependent expression.
28353       XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
28354       CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
28355
28356 C...d, u, s part by simple charge factor.
28357       XPGA(1)=(1D0/9D0)*CGAM
28358       XPGA(2)=(4D0/9D0)*CGAM
28359       XPGA(3)=(1D0/9D0)*CGAM
28360
28361 C...Also fill for antiquarks.
28362       DO 110 KF=1,5
28363         XPGA(-KF)=XPGA(KF)
28364   110 CONTINUE
28365
28366       RETURN
28367       END
28368
28369 C*********************************************************************
28370
28371 C...PYPDPI
28372 C...Gives pi+ parton distribution according to two different
28373 C...parametrizations.
28374
28375       SUBROUTINE PYPDPI(X,Q2,XPPI)
28376
28377 C...Double precision and integer declarations.
28378       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28379       IMPLICIT INTEGER(I-N)
28380       INTEGER PYK,PYCHGE,PYCOMP
28381 C...Commonblocks.
28382       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28383       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28384       COMMON/PYINT1/MINT(400),VINT(400)
28385       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28386 C...Local arrays.
28387       DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
28388
28389 C...The following data lines are coefficients needed in the
28390 C...Owens pion parton distribution parametrizations, see below.
28391 C...Expansion coefficients for up and down valence quark distributions.
28392       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
28393      &4.0000D-01,  7.0000D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
28394      &-6.2120D-02,  6.4780D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
28395      &-7.1090D-03,  1.3350D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
28396       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
28397      &4.0000D-01,  6.2800D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
28398      &-5.9090D-02,  6.4360D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
28399      &-6.5240D-03,  1.4510D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
28400 C...Expansion coefficients for gluon distribution.
28401       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
28402      &8.8800D-01,  0.0000D+00,  3.1100D+00,  6.0000D+00,  0.0000D+00,
28403      &-1.8020D+00, -1.5760D+00, -1.3170D-01,  2.8010D+00, -1.7280D+01,
28404      &1.8120D+00,  1.2000D+00,  5.0680D-01, -1.2160D+01,  2.0490D+01/
28405       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
28406      &7.9400D-01,  0.0000D+00,  2.8900D+00,  6.0000D+00,  0.0000D+00,
28407      &-9.1440D-01, -1.2370D+00,  5.9660D-01, -3.6710D+00, -8.1910D+00,
28408      &5.9660D-01,  6.5820D-01, -2.5500D-01, -2.3040D+00,  7.7580D+00/
28409 C...Expansion coefficients for (up+down+strange) quark sea distribution.
28410       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
28411      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
28412      &-2.4280D-01, -2.1200D-01,  8.6730D-01,  1.2660D+00,  2.3820D+00,
28413      &1.3860D-01,  3.6710D-03,  4.7470D-02, -2.2150D+00,  3.4820D-01/
28414       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
28415      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
28416      &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00,  5.6210D-01,
28417      &-1.7400D-01, -9.6230D-02,  1.5750D+00,  1.3780D+00, -2.7010D-01/
28418 C...Expansion coefficients for charm quark sea distribution.
28419       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
28420      &0.0000D+00, -2.2120D-02,  2.8940D+00,  0.0000D+00,  0.0000D+00,
28421      &7.9280D-02, -3.7850D-01,  9.4330D+00,  5.2480D+00,  8.3880D+00,
28422      &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
28423       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
28424      &0.0000D+00, -8.8200D-02,  1.9240D+00,  0.0000D+00,  0.0000D+00,
28425      &6.2290D-02, -2.8920D-01,  2.4240D-01, -4.4630D+00, -8.3670D-01,
28426      &-4.0990D-02, -1.0820D-01,  2.0360D+00,  5.2090D+00, -4.8400D-02/
28427
28428 C...Euler's beta function, requires ordinary Gamma function
28429       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
28430
28431 C...Reset output array.
28432       DO 100 KFL=-6,6
28433         XPPI(KFL)=0D0
28434   100 CONTINUE
28435
28436       IF(MSTP(53).LE.2) THEN
28437 C...Pion parton distributions from Owens.
28438 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
28439
28440 C...Determine set, Lambda and s expansion variable.
28441         NSET=MSTP(53)
28442         IF(NSET.EQ.1) ALAM=0.2D0
28443         IF(NSET.EQ.2) ALAM=0.4D0
28444         VINT(231)=4D0
28445         IF(MSTP(57).LE.0) THEN
28446           SD=0D0
28447         ELSE
28448           Q2IN=MIN(2D3,MAX(4D0,Q2))
28449           SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
28450         ENDIF
28451
28452 C...Calculate parton distributions.
28453         DO 120 KFL=1,4
28454           DO 110 IS=1,5
28455             TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
28456      &      COW(3,IS,KFL,NSET)*SD**2
28457   110     CONTINUE
28458           IF(KFL.EQ.1) THEN
28459             XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
28460           ELSE
28461             XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
28462      &      TS(5)*X**2)
28463           ENDIF
28464   120   CONTINUE
28465
28466 C...Put into output array.
28467         XPPI(0)=XQ(2)
28468         XPPI(1)=XQ(3)/6D0
28469         XPPI(2)=XQ(1)+XQ(3)/6D0
28470         XPPI(3)=XQ(3)/6D0
28471         XPPI(4)=XQ(4)
28472         XPPI(-1)=XQ(1)+XQ(3)/6D0
28473         XPPI(-2)=XQ(3)/6D0
28474         XPPI(-3)=XQ(3)/6D0
28475         XPPI(-4)=XQ(4)
28476
28477 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
28478 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
28479 C...10^-5 < x < 1.
28480       ELSE
28481
28482 C...Determine s expansion variable and some x expressions.
28483         VINT(231)=0.25D0
28484         IF(MSTP(57).LE.0) THEN
28485           SD=0D0
28486         ELSE
28487           Q2IN=MIN(1D8,MAX(0.25D0,Q2))
28488           SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
28489         ENDIF
28490         SD2=SD**2
28491         XL=-LOG(X)
28492         XS=SQRT(X)
28493
28494 C...Evaluate valence, gluon and sea distributions.
28495         XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
28496      &  (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
28497         XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
28498      &  SD-0.175D0*SD2)+
28499      &  (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
28500      &  SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
28501      &  XL)))*
28502      &  (1D0-X)**(0.390D0+1.053D0*SD)
28503         XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
28504      &  X)**3.359D0*
28505      &  EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
28506      &  XL))/
28507      &  XL**(2.538D0-0.763D0*SD)
28508         IF(SD.LE.0.888D0) THEN
28509           XFCHM=0D0
28510         ELSE
28511           XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
28512      &    0.771D0*SD)*
28513      &    EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
28514      &    XL))
28515         ENDIF
28516         IF(SD.LE.1.351D0) THEN
28517           XFBOT=0D0
28518         ELSE
28519           XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
28520      &    EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
28521      &    XL))
28522         ENDIF
28523
28524 C...Put into output array.
28525         XPPI(0)=XFGLU
28526         XPPI(1)=XFSEA
28527         XPPI(2)=XFSEA
28528         XPPI(3)=XFSEA
28529         XPPI(4)=XFCHM
28530         XPPI(5)=XFBOT
28531         DO 130 KFL=1,5
28532           XPPI(-KFL)=XPPI(KFL)
28533   130   CONTINUE
28534         XPPI(2)=XPPI(2)+XFVAL
28535         XPPI(-1)=XPPI(-1)+XFVAL
28536       ENDIF
28537
28538       RETURN
28539       END
28540
28541 C*********************************************************************
28542
28543 C...PYPDPR
28544 C...Gives proton parton distributions according to a few different
28545 C...parametrizations.
28546
28547       SUBROUTINE PYPDPR(X,Q2,XPPR)
28548
28549 C...Double precision and integer declarations.
28550       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28551       IMPLICIT INTEGER(I-N)
28552       INTEGER PYK,PYCHGE,PYCOMP
28553 C...Commonblocks.
28554       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28555       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28556       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28557       COMMON/PYINT1/MINT(400),VINT(400)
28558       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28559 C...Arrays and data.
28560       DIMENSION XPPR(-6:6),Q2MIN(16)
28561       DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
28562      &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
28563
28564 C...Reset output array.
28565       DO 100 KFL=-6,6
28566         XPPR(KFL)=0D0
28567   100 CONTINUE
28568
28569 C...Common preliminaries.
28570       NSET=MAX(1,MIN(16,MSTP(51)))
28571       IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
28572       VINT(231)=Q2MIN(NSET)
28573       IF(MSTP(57).EQ.0) THEN
28574         Q2L=Q2MIN(NSET)
28575       ELSE
28576         Q2L=MAX(Q2MIN(NSET),Q2)
28577       ENDIF
28578
28579       IF(NSET.GE.1.AND.NSET.LE.3) THEN
28580 C...Interface to the CTEQ 3 parton distributions.
28581         QRT=SQRT(MAX(1D0,Q2L))
28582
28583 C...Loop over flavours.
28584         DO 110 I=-6,6
28585           IF(I.LE.0) THEN
28586             XPPR(I)=PYCTEQ(NSET,I,X,QRT)
28587           ELSEIF(I.LE.2) THEN
28588             XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
28589           ELSE
28590             XPPR(I)=XPPR(-I)
28591           ENDIF
28592   110   CONTINUE
28593
28594       ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
28595 C...Interface to the GRV 94 distributions.
28596         IF(NSET.EQ.4) THEN
28597           CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28598         ELSEIF(NSET.EQ.5) THEN
28599           CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28600         ELSE
28601           CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28602         ENDIF
28603
28604 C...Put into output array.
28605         XPPR(0)=GL
28606         XPPR(-1)=0.5D0*(UDB+DEL)
28607         XPPR(-2)=0.5D0*(UDB-DEL)
28608         XPPR(-3)=SB
28609         XPPR(-4)=CHM
28610         XPPR(-5)=BOT
28611         XPPR(1)=DV+XPPR(-1)
28612         XPPR(2)=UV+XPPR(-2)
28613         XPPR(3)=SB
28614         XPPR(4)=CHM
28615         XPPR(5)=BOT
28616
28617       ELSEIF(NSET.EQ.7) THEN
28618 C...Interface to the CTEQ 5L parton distributions.
28619 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
28620 C...freezing x*f(x,Q2) at borders.
28621         QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28622         XIN=MAX(1D-6,MIN(1D0,X))
28623
28624 C...Loop over flavours (with u <-> d notation mismatch).
28625         SUMUDB=PYCT5L(-1,XIN,QRT)
28626         RATUDB=PYCT5L(-2,XIN,QRT)
28627         DO 120 I=-5,2
28628           IF(I.EQ.1) THEN
28629             XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
28630           ELSEIF(I.EQ.2) THEN
28631             XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
28632           ELSEIF(I.EQ.-1) THEN
28633             XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28634           ELSEIF(I.EQ.-2) THEN
28635             XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28636           ELSE
28637             XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
28638             IF(I.LT.0) XPPR(-I)=XPPR(I)
28639           ENDIF
28640   120   CONTINUE
28641
28642       ELSEIF(NSET.EQ.8) THEN
28643 C...Interface to the CTEQ 5M1 parton distributions.
28644         QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28645         XIN=MAX(1D-6,MIN(1D0,X))
28646
28647 C...Loop over flavours (with u <-> d notation mismatch).
28648         SUMUDB=PYCT5M(-1,XIN,QRT)
28649         RATUDB=PYCT5M(-2,XIN,QRT)
28650         DO 130 I=-5,2
28651           IF(I.EQ.1) THEN
28652             XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
28653           ELSEIF(I.EQ.2) THEN
28654             XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
28655           ELSEIF(I.EQ.-1) THEN
28656             XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28657           ELSEIF(I.EQ.-2) THEN
28658             XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28659           ELSE
28660             XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
28661             IF(I.LT.0) XPPR(-I)=XPPR(I)
28662           ENDIF
28663   130   CONTINUE
28664
28665       ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
28666 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
28667 C...obsolete but offers backwards compatibility.
28668         CALL PYPDPO(X,Q2L,XPPR)
28669
28670 C...Symmetric choice for debugging only
28671       ELSEIF(NSET.EQ.16) THEN
28672         XPPR(0)=.5D0/X
28673         XPPR(1)=.05D0/X
28674         XPPR(2)=.05D0/X
28675         XPPR(3)=.05D0/X
28676         XPPR(4)=.05D0/X
28677         XPPR(5)=.05D0/X
28678         XPPR(-1)=.05D0/X
28679         XPPR(-2)=.05D0/X
28680         XPPR(-3)=.05D0/X
28681         XPPR(-4)=.05D0/X
28682         XPPR(-5)=.05D0/X
28683
28684       ENDIF
28685
28686       RETURN
28687       END
28688
28689 C*********************************************************************
28690
28691 C...PYCTEQ
28692 C...Gives the CTEQ 3 parton distribution function sets in
28693 C...parametrized form, of October 24, 1994.
28694 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
28695 C...J. Qiu, W.K. Tung and H. Weerts.
28696
28697       FUNCTION PYCTEQ (ISET, IPRT, X, Q)
28698
28699 C...Double precision declaration.
28700       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28701       IMPLICIT INTEGER(I-N)
28702
28703 C...Data on Lambda values of fits, minimum Q and quark masses.
28704       DIMENSION ALM(3), QMS(4:6)
28705       DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
28706       DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
28707
28708 C....Check flavour thresholds. Set up QI for SB.
28709       IP = IABS(IPRT)
28710       IF(IP .GE. 4) THEN
28711         IF(Q .LE. QMS(IP)) THEN
28712           PYCTEQ = 0D0
28713           RETURN
28714         ENDIF
28715         QI = QMS(IP)
28716       ELSE
28717         QI = QMN
28718       ENDIF
28719
28720 C...Use "standard lambda" of parametrization program for expansion.
28721       ALAM = ALM (ISET)
28722       SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
28723       SB = LOG (SBL)
28724       SB2 = SB*SB
28725       SB3 = SB2*SB
28726
28727 C...Expansion for CTEQ3L.
28728       IF(ISET .EQ. 1) THEN
28729         IF(IPRT .EQ. 2) THEN
28730           A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
28731      &    0.3171D+00*SB3)
28732           A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
28733           A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
28734           A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
28735           A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
28736           A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
28737         ELSEIF(IPRT .EQ. 1) THEN
28738           A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
28739      &    0.7728D+00*SB3)
28740           A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
28741           A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
28742           A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
28743           A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
28744           A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
28745         ELSEIF(IPRT .EQ. 0) THEN
28746           A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
28747      &    0.5343D+00*SB3)
28748           A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
28749           A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
28750           A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
28751           A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
28752           A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
28753         ELSEIF(IPRT .EQ. -1) THEN
28754           A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
28755      &    0.2031D+01*SB3)
28756           A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
28757           A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
28758           A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
28759           A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
28760           A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
28761         ELSEIF(IPRT .EQ. -2) THEN
28762           A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
28763      &    0.9872D-01*SB3)
28764           A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
28765           A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
28766           A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
28767           A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
28768           A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
28769         ELSEIF(IPRT .EQ. -3) THEN
28770           A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
28771      &    0.8390D+00*SB3)
28772           A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
28773           A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
28774           A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
28775           A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
28776           A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
28777         ELSEIF(IPRT .EQ. -4) THEN
28778           A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
28779      &    0.1651D-01*SB2)
28780           A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
28781           A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
28782           A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
28783           A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
28784           A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
28785         ELSEIF(IPRT .EQ. -5) THEN
28786           A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
28787      &    0.3702D+01*SB2)
28788           A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
28789           A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
28790           A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
28791           A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
28792           A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
28793         ELSEIF(IPRT .EQ. -6) THEN
28794           A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
28795      &    0.6943D+00*SB2)
28796           A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
28797           A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
28798           A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
28799           A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
28800           A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
28801         ENDIF
28802
28803 C...Expansion for CTEQ3M.
28804       ELSEIF(ISET .EQ. 2) THEN
28805         IF(IPRT .EQ. 2) THEN
28806           A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
28807      &    0.2935D+00*SB3)
28808           A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
28809           A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
28810           A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
28811           A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
28812           A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
28813         ELSEIF(IPRT .EQ. 1) THEN
28814           A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
28815      &    0.4305D-01*SB3)
28816           A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
28817           A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
28818           A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
28819           A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
28820           A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
28821         ELSEIF(IPRT .EQ. 0) THEN
28822           A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
28823      &    0.1037D-01*SB3)
28824           A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
28825           A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
28826           A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
28827           A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
28828           A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
28829         ELSEIF(IPRT .EQ. -1) THEN
28830           A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
28831      &    0.1602D+01*SB3)
28832           A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
28833           A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
28834           A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
28835           A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
28836           A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
28837         ELSEIF(IPRT .EQ. -2) THEN
28838           A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
28839      &    0.2496D+00*SB3)
28840           A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
28841           A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
28842           A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
28843           A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
28844           A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
28845         ELSEIF(IPRT .EQ. -3) THEN
28846           A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
28847      &    0.1936D+01*SB3)
28848           A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
28849           A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
28850           A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
28851           A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
28852           A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
28853         ELSEIF(IPRT .EQ. -4) THEN
28854           A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
28855      &    0.5348D+00*SB2)
28856           A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
28857           A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
28858           A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
28859           A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
28860           A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
28861         ELSEIF(IPRT .EQ. -5) THEN
28862           A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
28863      &    0.1569D+01*SB2)
28864           A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
28865           A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
28866           A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
28867           A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
28868           A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
28869         ELSEIF(IPRT .EQ. -6) THEN
28870           A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
28871      &    0.8838D+01*SB2)
28872           A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
28873           A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
28874           A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
28875           A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
28876           A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
28877         ENDIF
28878
28879 C...Expansion for CTEQ3D.
28880       ELSEIF(ISET .EQ. 3) THEN
28881         IF(IPRT .EQ. 2) THEN
28882           A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
28883      &    0.2902D+00*SB3)
28884           A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
28885           A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
28886           A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
28887           A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
28888           A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
28889         ELSEIF(IPRT .EQ. 1) THEN
28890           A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
28891      &    0.7257D+00*SB3)
28892           A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
28893           A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
28894           A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
28895           A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
28896           A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
28897         ELSEIF(IPRT .EQ. 0) THEN
28898           A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
28899      &    0.2734D-04*SB3)
28900           A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
28901           A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
28902           A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
28903           A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
28904           A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
28905         ELSEIF(IPRT .EQ. -1) THEN
28906           A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
28907      &    0.1671D+01*SB3)
28908           A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
28909           A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
28910           A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
28911           A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
28912           A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
28913         ELSEIF(IPRT .EQ. -2) THEN
28914           A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
28915      &    0.2223D+00*SB3)
28916           A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
28917           A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
28918           A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
28919           A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
28920           A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
28921         ELSEIF(IPRT .EQ. -3) THEN
28922           A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
28923      &    0.1937D+01*SB3)
28924           A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
28925           A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
28926           A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
28927           A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
28928           A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
28929         ELSEIF(IPRT .EQ. -4) THEN
28930           A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
28931      &    0.5137D+00*SB2)
28932           A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
28933           A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
28934           A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
28935           A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
28936           A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
28937         ELSEIF(IPRT .EQ. -5) THEN
28938           A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
28939      &    0.2143D+01*SB2)
28940           A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
28941           A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
28942           A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
28943           A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
28944           A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
28945         ELSEIF(IPRT .EQ. -6) THEN
28946           A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
28947      &    0.9998D+01*SB2)
28948           A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
28949           A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
28950           A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
28951           A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
28952           A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
28953         ENDIF
28954       ENDIF
28955
28956 C...Calculation of x * f(x, Q).
28957       PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
28958      &   *(LOG(1D0+1D0/X))**A5 )
28959
28960       RETURN
28961       END
28962
28963 C*********************************************************************
28964
28965 C...PYGRVL
28966 C...Gives the GRV 94 L (leading order) parton distribution function set
28967 C...in parametrized form.
28968 C...Authors: M. Glueck, E. Reya and A. Vogt.
28969
28970       SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28971
28972 C...Double precision declaration.
28973       IMPLICIT DOUBLE PRECISION (A - Z)
28974
28975 C...Common expressions.
28976       MU2  = 0.23D0
28977       LAM2 = 0.2322D0 * 0.2322D0
28978       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
28979       DS = SQRT (S)
28980       S2 = S * S
28981       S3 = S2 * S
28982
28983 C...uv :
28984       NU  =  2.284D0 + 0.802D0 * S + 0.055D0 * S2
28985       AKU =  0.590D0 - 0.024D0 * S
28986       BKU =  0.131D0 + 0.063D0 * S
28987       AU  = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
28988       BU  =  0.213D0 + 2.669D0 * S - 0.728D0 * S2
28989       CU  =  8.854D0 - 9.135D0 * S + 1.979D0 * S2
28990       DU  =  2.997D0 + 0.753D0 * S - 0.076D0 * S2
28991       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
28992
28993 C...dv :
28994       ND  =  0.371D0 + 0.083D0 * S + 0.039D0 * S2
28995       AKD =  0.376D0
28996       BKD =  0.486D0 + 0.062D0 * S
28997       AD  = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
28998       BD  =  12.41D0 - 10.52D0 * S + 2.267D0 * S2
28999       CD  =  6.373D0 - 6.208D0 * S + 1.418D0 * S2
29000       DD  =  3.691D0 + 0.799D0 * S - 0.071D0 * S2
29001       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29002
29003 C...del :
29004       NE  =  0.082D0 + 0.014D0 * S + 0.008D0 * S2
29005       AKE =  0.409D0 - 0.005D0 * S
29006       BKE =  0.799D0 + 0.071D0 * S
29007       AE  = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29008       BE  =  90.31D0 - 74.15D0 * S + 7.645D0 * S2
29009       CE  =  0.0D0
29010       DE  =  7.486D0 + 1.217D0 * S - 0.159D0 * S2
29011       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29012
29013 C...udb :
29014       ALX =  1.451D0
29015       BEX =  0.271D0
29016       AKX =  0.410D0 - 0.232D0 * S
29017       BKX =  0.534D0 - 0.457D0 * S
29018       AGX =  0.890D0 - 0.140D0 * S
29019       BGX = -0.981D0
29020       CX  =  0.320D0 + 0.683D0 * S
29021       DX  =  4.752D0 + 1.164D0 * S + 0.286D0 * S2
29022       EX  =  4.119D0 + 1.713D0 * S
29023       ESX =  0.682D0 + 2.978D0 * S
29024       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29025      & DX, EX, ESX)
29026
29027 C...sb :
29028       STS =  0D0
29029       ALS =  0.914D0
29030       BES =  0.577D0
29031       AKS =  1.798D0 - 0.596D0 * S
29032       AS  = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29033       BS  =  18.92D0 - 16.73D0 * DS + 5.168D0 * S
29034       DST =  6.379D0 - 0.350D0 * S  + 0.142D0 * S2
29035       EST =  3.981D0 + 1.638D0 * S
29036       ESS =  6.402D0
29037       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29038
29039 C...cb :
29040       STC =  0.888D0
29041       ALC =  1.01D0
29042       BEC =  0.37D0
29043       AKC =  0D0
29044       AC  =  0D0
29045       BC  =  4.24D0  - 0.804D0 * S
29046       DCT =  3.46D0  - 1.076D0 * S
29047       ECT =  4.61D0  + 1.49D0  * S
29048       ESC =  2.555D0 + 1.961D0 * S
29049       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29050
29051 C...bb :
29052       STB =  1.351D0
29053       ALB =  1.00D0
29054       BEB =  0.51D0
29055       AKB =  0D0
29056       AB  =  0D0
29057       BB  =  1.848D0
29058       DBT =  2.929D0 + 1.396D0 * S
29059       EBT =  4.71D0  + 1.514D0 * S
29060       ESB =  4.02D0  + 1.239D0 * S
29061       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29062
29063 C...gl :
29064       ALG =  0.524D0
29065       BEG =  1.088D0
29066       AKG =  1.742D0 - 0.930D0 * S
29067       BKG =                         - 0.399D0 * S2
29068       AG  =  7.486D0 - 2.185D0 * S
29069       BG  =  16.69D0 - 22.74D0 * S  + 5.779D0 * S2
29070       CG  = -25.59D0 + 29.71D0 * S  - 7.296D0 * S2
29071       DG  =  2.792D0 + 2.215D0 * S  + 0.422D0 * S2 - 0.104D0 * S3
29072       EG  =  0.807D0 + 2.005D0 * S
29073       ESG =  3.841D0 + 0.316D0 * S
29074       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
29075      & DG, EG, ESG)
29076
29077       RETURN
29078       END
29079
29080 C*********************************************************************
29081
29082 C...PYGRVM
29083 C...Gives the GRV 94 M (MSbar) parton distribution function set
29084 C...in parametrized form.
29085 C...Authors: M. Glueck, E. Reya and A. Vogt.
29086
29087       SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29088
29089 C...Double precision declaration.
29090       IMPLICIT DOUBLE PRECISION (A - Z)
29091
29092 C...Common expressions.
29093       MU2  = 0.34D0
29094       LAM2 = 0.248D0 * 0.248D0
29095       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29096       DS = SQRT (S)
29097       S2 = S * S
29098       S3 = S2 * S
29099
29100 C...uv :
29101       NU  =  1.304D0 + 0.863D0 * S
29102       AKU =  0.558D0 - 0.020D0 * S
29103       BKU =          0.183D0 * S
29104       AU  = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
29105       BU  =  6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
29106       CU  =  7.771D0 - 10.09D0 * S + 2.630D0 * S2
29107       DU  =  3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
29108       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29109
29110 C...dv :
29111       ND  =  0.102D0 - 0.017D0 * S + 0.005D0 * S2
29112       AKD =  0.270D0 - 0.019D0 * S
29113       BKD =  0.260D0
29114       AD  =  2.393D0 + 6.228D0 * S - 0.881D0 * S2
29115       BD  =  46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
29116       CD  =  17.83D0 - 53.47D0 * S + 21.24D0 * S2
29117       DD  =  4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
29118       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29119
29120 C...del :
29121       NE  =  0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
29122       AKE =  0.409D0 - 0.007D0 * S
29123       BKE =  0.782D0 + 0.082D0 * S
29124       AE  = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
29125       BE  =  90.20D0 - 74.97D0 * S + 4.526D0 * S2
29126       CE  =  0.0D0
29127       DE  =  8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
29128       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29129
29130 C...udb :
29131       ALX =  0.877D0
29132       BEX =  0.561D0
29133       AKX =  0.275D0
29134       BKX =  0.0D0
29135       AGX =  0.997D0
29136       BGX =  3.210D0 - 1.866D0 * S
29137       CX  =  7.300D0
29138       DX  =  9.010D0 + 0.896D0 * DS + 0.222D0 * S2
29139       EX  =  3.077D0 + 1.446D0 * S
29140       ESX =  3.173D0 - 2.445D0 * DS + 2.207D0 * S
29141       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29142      & DX, EX, ESX)
29143
29144 C...sb :
29145       STS =  0D0
29146       ALS =  0.756D0
29147       BES =  0.216D0
29148       AKS =  1.690D0 + 0.650D0 * DS - 0.922D0 * S
29149       AS  = -4.329D0 + 1.131D0 * S
29150       BS  =  9.568D0 - 1.744D0 * S
29151       DST =  9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
29152       EST =  3.031D0 + 1.639D0 * S
29153       ESS =  5.837D0 + 0.815D0 * S
29154       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29155
29156 C...cb :
29157       STC =  0.820D0
29158       ALC =  0.98D0
29159       BEC =  0D0
29160       AKC = -0.625D0 - 0.523D0 * S
29161       AC  =  0D0
29162       BC  =  1.896D0 + 1.616D0 * S
29163       DCT =  4.12D0  + 0.683D0 * S
29164       ECT =  4.36D0  + 1.328D0 * S
29165       ESC =  0.677D0 + 0.679D0 * S
29166       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29167
29168 C...bb :
29169       STB =  1.297D0
29170       ALB =  0.99D0
29171       BEB =  0D0
29172       AKB =          - 0.193D0 * S
29173       AB  =  0D0
29174       BB  =  0D0
29175       DBT =  3.447D0 + 0.927D0 * S
29176       EBT =  4.68D0  + 1.259D0 * S
29177       ESB =  1.892D0 + 2.199D0 * S
29178       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29179
29180 C...gl :
29181        ALG =  1.014D0
29182        BEG =  1.738D0
29183        AKG =  1.724D0 + 0.157D0 * S
29184        BKG =  0.800D0 + 1.016D0 * S
29185        AG  =  7.517D0 - 2.547D0 * S
29186        BG  =  34.09D0 - 52.21D0 * DS + 17.47D0 * S
29187        CG  =  4.039D0 + 1.491D0 * S
29188        DG  =  3.404D0 + 0.830D0 * S
29189        EG  = -1.112D0 + 3.438D0 * S  - 0.302D0 * S2
29190        ESG =  3.256D0 - 0.436D0 * S
29191        GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29192
29193        RETURN
29194        END
29195
29196 C*********************************************************************
29197
29198 C...PYGRVD
29199 C...Gives the GRV 94 D (DIS) parton distribution function set
29200 C...in parametrized form.
29201 C...Authors: M. Glueck, E. Reya and A. Vogt.
29202
29203       SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29204
29205 C...Double precision declaration.
29206       IMPLICIT DOUBLE PRECISION (A - Z)
29207
29208 C...Common expressions.
29209       MU2  = 0.34D0
29210       LAM2 = 0.248D0 * 0.248D0
29211       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29212       DS = SQRT (S)
29213       S2 = S * S
29214       S3 = S2 * S
29215
29216 C...uv :
29217       NU  =  2.484D0 + 0.116D0 * S + 0.093D0 * S2
29218       AKU =  0.563D0 - 0.025D0 * S
29219       BKU =  0.054D0 + 0.154D0 * S
29220       AU  = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
29221       BU  = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
29222       CU  =  11.52D0 - 12.99D0 * S + 3.161D0 * S2
29223       DU  =  2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
29224       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29225
29226 C...dv :
29227       ND  =  0.156D0 - 0.017D0 * S
29228       AKD =  0.299D0 - 0.022D0 * S
29229       BKD =  0.259D0 - 0.015D0 * S
29230       AD  =  3.445D0 + 1.278D0 * S + 0.326D0 * S2
29231       BD  = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
29232       CD  =  55.45D0 - 69.92D0 * S + 20.78D0 * S2
29233       DD  =  3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
29234       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29235
29236 C...del :
29237       NE  =  0.099D0 + 0.019D0 * S + 0.002D0 * S2
29238       AKE =  0.419D0 - 0.013D0 * S
29239       BKE =  1.064D0 - 0.038D0 * S
29240       AE  = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
29241       BE  =  28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
29242       CE  =  84.57D0 - 108.8D0 * S + 31.52D0 * S2
29243       DE  =  7.469D0 + 2.480D0 * S - 0.866D0 * S2
29244       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29245
29246 C...udb :
29247       ALX =  1.215D0
29248       BEX =  0.466D0
29249       AKX =  0.326D0 + 0.150D0 * S
29250       BKX =  0.956D0 + 0.405D0 * S
29251       AGX =  0.272D0
29252       BGX =  3.794D0 - 2.359D0 * DS
29253       CX  =  2.014D0
29254       DX  =  7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
29255       EX  =  3.049D0 + 1.597D0 * S
29256       ESX =  4.396D0 - 4.594D0 * DS + 3.268D0 * S
29257       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29258      & DX, EX, ESX)
29259
29260 C...sb :
29261       STS =  0D0
29262       ALS =  0.175D0
29263       BES =  0.344D0
29264       AKS =  1.415D0 - 0.641D0 * DS
29265       AS  =  0.580D0 - 9.763D0 * DS + 6.795D0 * S  - 0.558D0 * S2
29266       BS  =  5.617D0 + 5.709D0 * DS - 3.972D0 * S
29267       DST =  13.78D0 - 9.581D0 * S  + 5.370D0 * S2 - 0.996D0 * S3
29268       EST =  4.546D0 + 0.372D0 * S2
29269       ESS =  5.053D0 - 1.070D0 * S  + 0.805D0 * S2
29270       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29271
29272 C...cb :
29273       STC =  0.820D0
29274       ALC =  0.98D0
29275       BEC =  0D0
29276       AKC = -0.625D0 - 0.523D0 * S
29277       AC  =  0D0
29278       BC  =  1.896D0 + 1.616D0 * S
29279       DCT =  4.12D0  + 0.683D0 * S
29280       ECT =  4.36D0  + 1.328D0 * S
29281       ESC =  0.677D0 + 0.679D0 * S
29282       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29283
29284 C...bb :
29285       STB =  1.297D0
29286       ALB =  0.99D0
29287       BEB =  0D0
29288       AKB =          - 0.193D0 * S
29289       AB  =  0D0
29290       BB  =  0D0
29291       DBT =  3.447D0 + 0.927D0 * S
29292       EBT =  4.68D0  + 1.259D0 * S
29293       ESB =  1.892D0 + 2.199D0 * S
29294       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29295
29296 C...gl :
29297       ALG =  1.258D0
29298       BEG =  1.846D0
29299       AKG =  2.423D0
29300       BKG =  2.427D0 + 1.311D0 * S  - 0.153D0 * S2
29301       AG  =  25.09D0 - 7.935D0 * S
29302       BG  = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
29303       CG  =  590.3D0 - 173.8D0 * S
29304       DG  =  5.196D0 + 1.857D0 * S
29305       EG  = -1.648D0 + 3.988D0 * S  - 0.432D0 * S2
29306       ESG =  3.232D0 - 0.542D0 * S
29307       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29308
29309       RETURN
29310       END
29311
29312 C*********************************************************************
29313
29314 C...PYGRVV
29315 C...Auxiliary for the GRV 94 parton distribution functions
29316 C...for u and d valence and d-u sea.
29317 C...Authors: M. Glueck, E. Reya and A. Vogt.
29318
29319       FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
29320
29321 C...Double precision declaration.
29322       IMPLICIT DOUBLE PRECISION (A - Z)
29323
29324 C...Evaluation.
29325       DX = SQRT (X)
29326       PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
29327      & (1D0- X)**D
29328
29329       RETURN
29330       END
29331
29332 C*********************************************************************
29333
29334 C...PYGRVW
29335 C...Auxiliary for the GRV 94 parton distribution functions
29336 C...for d+u sea and gluon.
29337 C...Authors: M. Glueck, E. Reya and A. Vogt.
29338
29339       FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
29340
29341 C...Double precision declaration.
29342       IMPLICIT DOUBLE PRECISION (A - Z)
29343
29344 C...Evaluation.
29345       LX = LOG (1D0/X)
29346       PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
29347      &     * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
29348
29349       RETURN
29350       END
29351
29352 C*********************************************************************
29353
29354 C...PYGRVS
29355 C...Auxiliary for the GRV 94 parton distribution functions
29356 C...for s, c and b sea.
29357 C...Authors: M. Glueck, E. Reya and A. Vogt.
29358
29359       FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
29360
29361 C...Double precision declaration.
29362       IMPLICIT DOUBLE PRECISION (A - Z)
29363
29364 C...Evaluation.
29365       IF(S.LE.STH) THEN
29366         PYGRVS = 0D0
29367       ELSE
29368         DX = SQRT (X)
29369         LX = LOG (1D0/X)
29370         PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
29371      &     (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
29372       ENDIF
29373
29374       RETURN
29375       END
29376
29377 C*********************************************************************
29378
29379 C...PYCT5L
29380 C...Auxiliary function for parametrization of CTEQ5L.
29381 C...Author: J. Pumplin 9/99.
29382
29383 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
29384 C...in Parametrized Form
29385 C...            September 15, 1999
29386 C
29387 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
29388 C...      CTEQ5 PPARTON DISTRIBUTIONS"
29389 C...hep-ph/9903282
29390
29391 C...The CTEQ5M1 set given here is an updated version of the original
29392 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
29393 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
29394 C...almost all applications.
29395 C...The improvement is in the QCD evolution which is now more
29396 C...accurate, and which agrees completely with the benchmark work
29397 C...of the HERA 96/97 Workshop.
29398 C...The differences between the parametrized and the corresponding
29399 C...table versions (on which it is based) are of similar order as
29400 C...between the two version.
29401
29402 C...!! Because accurate parametrizations over a wide range of (x,Q)
29403 C...is hard to obtain, only the most widely used sets CTEQ5M and
29404 C...CTEQ5L are available in parametrized form for now.
29405
29406 C...These parametrizations were obtained by Jon Pumplin.
29407
29408 C  Iset   PDF        Description              Alpha_s(Mz)  Lam4  Lam5
29409 C -------------------------------------------------------------------
29410 C   1    CTEQ5M1  Standard NLO MSbar scheme      0.118     326   226
29411 C   3    CTEQ5L   Leading Order                  0.127     192   146
29412 C -------------------------------------------------------------------
29413 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
29414 C...order form of Alpha_s!!  Alpha_s(Mz) gives the absolute
29415 C...calibration.
29416
29417 C...The two Iset value are adopted to agree with the standard table
29418 C...versions.
29419
29420 C...Range of validity:
29421 C...The range of (x, Q) covered by this parametrization of the QCD
29422 C...evolved parton distributions is 1E-6 < x < 1 ;
29423 C...1.1 GeV < Q < 10 TeV.  Of course, the PDF's are constrained by
29424 C...data only in a subset of that region; and the assumed DGLAP
29425 C...evolution is unlikely to be valid for all of it either.
29426
29427 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
29428 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
29429 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
29430 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
29431
29432       FUNCTION PYCT5L(IFL,X,Q)
29433
29434 C...Double precision declaration.
29435       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29436       IMPLICIT INTEGER(I-N)
29437
29438       PARAMETER (NEX=8, NLF=2)
29439       DIMENSION AM(0:NEX,0:NLF,-5:2)
29440       DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29441       DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29442       DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29443       DIMENSION AF(0:NEX)
29444
29445       DATA MEXVEC( 2) / 8 /
29446       DATA MLFVEC( 2) / 2 /
29447       DATA UT1VEC( 2) /  0.4971265E+01 /
29448       DATA UT2VEC( 2) / -0.1105128E+01 /
29449       DATA ALFVEC( 2) /  0.2987216E+00 /
29450       DATA QMAVEC( 2) /  0.0000000E+00 /
29451       DATA (AM( 0,K, 2),K=0, 2)
29452      & /  0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
29453       DATA (AM( 1,K, 2),K=0, 2)
29454      & /  0.9714424E+00,  0.1011827E-01, -0.1023660E-01 /
29455       DATA (AM( 2,K, 2),K=0, 2)
29456      & / -0.1651006E+02,  0.7959721E+01,  0.8810563E+01 /
29457       DATA (AM( 3,K, 2),K=0, 2)
29458      & / -0.1643394E+02,  0.5892854E+01,  0.9348874E+01 /
29459       DATA (AM( 4,K, 2),K=0, 2)
29460      & /  0.3067422E+02,  0.4235796E+01, -0.5112136E+00 /
29461       DATA (AM( 5,K, 2),K=0, 2)
29462      & /  0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
29463       DATA (AM( 6,K, 2),K=0, 2)
29464      & / -0.1095451E+02,  0.3006577E+01,  0.5638136E+01 /
29465       DATA (AM( 7,K, 2),K=0, 2)
29466      & / -0.1172251E+02, -0.2183624E+01,  0.4955794E+01 /
29467       DATA (AM( 8,K, 2),K=0, 2)
29468      & /  0.1662533E-01,  0.7622870E-02, -0.4895887E-03 /
29469
29470       DATA MEXVEC( 1) / 8 /
29471       DATA MLFVEC( 1) / 2 /
29472       DATA UT1VEC( 1) /  0.2612618E+01 /
29473       DATA UT2VEC( 1) / -0.1258304E+06 /
29474       DATA ALFVEC( 1) /  0.3407552E+00 /
29475       DATA QMAVEC( 1) /  0.0000000E+00 /
29476       DATA (AM( 0,K, 1),K=0, 2)
29477      & /  0.9905300E+00, -0.4502235E+00,  0.1624441E+00 /
29478       DATA (AM( 1,K, 1),K=0, 2)
29479      & /  0.8867534E+00,  0.1630829E-01, -0.4049085E-01 /
29480       DATA (AM( 2,K, 1),K=0, 2)
29481      & /  0.8547974E+00,  0.3336301E+00,  0.1371388E+00 /
29482       DATA (AM( 3,K, 1),K=0, 2)
29483      & /  0.2941113E+00, -0.1527905E+01,  0.2331879E+00 /
29484       DATA (AM( 4,K, 1),K=0, 2)
29485      & /  0.3384235E+02,  0.3715315E+01,  0.8276930E+00 /
29486       DATA (AM( 5,K, 1),K=0, 2)
29487      & /  0.6230115E+01,  0.3134639E+01, -0.1729099E+01 /
29488       DATA (AM( 6,K, 1),K=0, 2)
29489      & / -0.1186928E+01, -0.3282460E+00,  0.1052020E+00 /
29490       DATA (AM( 7,K, 1),K=0, 2)
29491      & / -0.8545702E+01, -0.6247947E+01,  0.3692561E+01 /
29492       DATA (AM( 8,K, 1),K=0, 2)
29493      & /  0.1724598E-01,  0.7120465E-02,  0.4003646E-04 /
29494
29495       DATA MEXVEC( 0) / 8 /
29496       DATA MLFVEC( 0) / 2 /
29497       DATA UT1VEC( 0) / -0.4656819E+00 /
29498       DATA UT2VEC( 0) / -0.2742390E+03 /
29499       DATA ALFVEC( 0) /  0.4491863E+00 /
29500       DATA QMAVEC( 0) /  0.0000000E+00 /
29501       DATA (AM( 0,K, 0),K=0, 2)
29502      & /  0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
29503       DATA (AM( 1,K, 0),K=0, 2)
29504      & / -0.9421449E+02,  0.3995885E+01,  0.1607363E+01 /
29505       DATA (AM( 2,K, 0),K=0, 2)
29506      & /  0.4206383E+01,  0.2485954E+00,  0.2497468E+00 /
29507       DATA (AM( 3,K, 0),K=0, 2)
29508      & /  0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
29509       DATA (AM( 4,K, 0),K=0, 2)
29510      & / -0.1013897E+03, -0.7113478E+00,  0.2621865E+00 /
29511       DATA (AM( 5,K, 0),K=0, 2)
29512      & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
29513       DATA (AM( 6,K, 0),K=0, 2)
29514      & /  0.1627137E+01,  0.4954111E+00, -0.6387009E+00 /
29515       DATA (AM( 7,K, 0),K=0, 2)
29516      & /  0.1537698E+00, -0.2487878E+00,  0.8305947E+00 /
29517       DATA (AM( 8,K, 0),K=0, 2)
29518      & /  0.2496448E-01,  0.2457823E-02,  0.8234276E-03 /
29519
29520       DATA MEXVEC(-1) / 8 /
29521       DATA MLFVEC(-1) / 2 /
29522       DATA UT1VEC(-1) /  0.3862583E+01 /
29523       DATA UT2VEC(-1) / -0.1265969E+01 /
29524       DATA ALFVEC(-1) /  0.2457668E+00 /
29525       DATA QMAVEC(-1) /  0.0000000E+00 /
29526       DATA (AM( 0,K,-1),K=0, 2)
29527      & /  0.2647441E+02,  0.1059277E+02, -0.9176654E+00 /
29528       DATA (AM( 1,K,-1),K=0, 2)
29529      & /  0.1990636E+01,  0.8558918E-01,  0.4248667E-01 /
29530       DATA (AM( 2,K,-1),K=0, 2)
29531      & / -0.1476095E+02, -0.3276255E+02,  0.1558110E+01 /
29532       DATA (AM( 3,K,-1),K=0, 2)
29533      & / -0.2966889E+01, -0.3649037E+02,  0.1195914E+01 /
29534       DATA (AM( 4,K,-1),K=0, 2)
29535      & / -0.1000519E+03, -0.2464635E+01,  0.1964849E+00 /
29536       DATA (AM( 5,K,-1),K=0, 2)
29537      & /  0.3718331E+02,  0.4700389E+02, -0.2772142E+01 /
29538       DATA (AM( 6,K,-1),K=0, 2)
29539      & / -0.1872722E+02, -0.2291189E+02,  0.1089052E+01 /
29540       DATA (AM( 7,K,-1),K=0, 2)
29541      & / -0.1628146E+02, -0.1823993E+02,  0.2537369E+01 /
29542       DATA (AM( 8,K,-1),K=0, 2)
29543      & / -0.1156300E+01, -0.1280495E+00,  0.5153245E-01 /
29544
29545       DATA MEXVEC(-2) / 7 /
29546       DATA MLFVEC(-2) / 2 /
29547       DATA UT1VEC(-2) /  0.1895615E+00 /
29548       DATA UT2VEC(-2) / -0.3069097E+01 /
29549       DATA ALFVEC(-2) /  0.5293999E+00 /
29550       DATA QMAVEC(-2) /  0.0000000E+00 /
29551       DATA (AM( 0,K,-2),K=0, 2)
29552      & / -0.6556775E+00,  0.2490190E+00,  0.3966485E-01 /
29553       DATA (AM( 1,K,-2),K=0, 2)
29554      & /  0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
29555       DATA (AM( 2,K,-2),K=0, 2)
29556      & / -0.2371436E+01,  0.3566814E+00, -0.2834683E+00 /
29557       DATA (AM( 3,K,-2),K=0, 2)
29558      & / -0.6152826E+01,  0.8339877E+00, -0.7233230E+00 /
29559       DATA (AM( 4,K,-2),K=0, 2)
29560      & / -0.8346558E+01,  0.2892168E+01,  0.2137099E+00 /
29561       DATA (AM( 5,K,-2),K=0, 2)
29562      & /  0.1279530E+02,  0.1021114E+00,  0.5787439E+00 /
29563       DATA (AM( 6,K,-2),K=0, 2)
29564      & /  0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
29565       DATA (AM( 7,K,-2),K=0, 2)
29566      & / -0.2795725E+02, -0.5263392E+00,  0.1290229E+01 /
29567
29568       DATA MEXVEC(-3) / 7 /
29569       DATA MLFVEC(-3) / 2 /
29570       DATA UT1VEC(-3) /  0.3753257E+01 /
29571       DATA UT2VEC(-3) / -0.1113085E+01 /
29572       DATA ALFVEC(-3) /  0.3713141E+00 /
29573       DATA QMAVEC(-3) /  0.0000000E+00 /
29574       DATA (AM( 0,K,-3),K=0, 2)
29575      & /  0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
29576       DATA (AM( 1,K,-3),K=0, 2)
29577      & /  0.2702644E+01,  0.6763243E+00,  0.7231586E-02 /
29578       DATA (AM( 2,K,-3),K=0, 2)
29579      & / -0.1857924E+02,  0.3907500E+01,  0.5850109E+01 /
29580       DATA (AM( 3,K,-3),K=0, 2)
29581      & / -0.3044793E+02,  0.2639332E+01,  0.5566644E+01 /
29582       DATA (AM( 4,K,-3),K=0, 2)
29583      & / -0.4258011E+01, -0.5429244E+01,  0.4418946E+00 /
29584       DATA (AM( 5,K,-3),K=0, 2)
29585      & /  0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
29586       DATA (AM( 6,K,-3),K=0, 2)
29587      & / -0.1658858E+02,  0.2923275E+01,  0.2266286E+01 /
29588       DATA (AM( 7,K,-3),K=0, 2)
29589      & / -0.1149263E+02,  0.2877475E+01, -0.7999105E+00 /
29590
29591       DATA MEXVEC(-4) / 7 /
29592       DATA MLFVEC(-4) / 2 /
29593       DATA UT1VEC(-4) /  0.4400772E+01 /
29594       DATA UT2VEC(-4) / -0.1356116E+01 /
29595       DATA ALFVEC(-4) /  0.3712017E-01 /
29596       DATA QMAVEC(-4) /  0.1300000E+01 /
29597       DATA (AM( 0,K,-4),K=0, 2)
29598      & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
29599       DATA (AM( 1,K,-4),K=0, 2)
29600      & /  0.2754618E+01,  0.8338636E+00, -0.6885160E-01 /
29601       DATA (AM( 2,K,-4),K=0, 2)
29602      & / -0.1657987E+02,  0.1439143E+02, -0.6887240E+00 /
29603       DATA (AM( 3,K,-4),K=0, 2)
29604      & / -0.2800703E+02,  0.1535966E+02, -0.7377693E+00 /
29605       DATA (AM( 4,K,-4),K=0, 2)
29606      & / -0.6460216E+01, -0.4783019E+01,  0.4913297E+00 /
29607       DATA (AM( 5,K,-4),K=0, 2)
29608      & /  0.3141830E+02, -0.3178031E+02,  0.7136013E+01 /
29609       DATA (AM( 6,K,-4),K=0, 2)
29610      & / -0.1802509E+02,  0.1862163E+02, -0.4632843E+01 /
29611       DATA (AM( 7,K,-4),K=0, 2)
29612      & / -0.1240412E+02,  0.2565386E+02, -0.1066570E+02 /
29613
29614       DATA MEXVEC(-5) / 6 /
29615       DATA MLFVEC(-5) / 2 /
29616       DATA UT1VEC(-5) /  0.5562568E+01 /
29617       DATA UT2VEC(-5) / -0.1801317E+01 /
29618       DATA ALFVEC(-5) /  0.4952010E-02 /
29619       DATA QMAVEC(-5) /  0.4500000E+01 /
29620       DATA (AM( 0,K,-5),K=0, 2)
29621      & / -0.6031237E+01,  0.1992727E+01, -0.1076331E+01 /
29622       DATA (AM( 1,K,-5),K=0, 2)
29623      & /  0.2933912E+01,  0.5839674E+00,  0.7509435E-01 /
29624       DATA (AM( 2,K,-5),K=0, 2)
29625      & / -0.8284919E+01,  0.1488593E+01, -0.8251678E+00 /
29626       DATA (AM( 3,K,-5),K=0, 2)
29627      & / -0.1925986E+02,  0.2805753E+01, -0.3015446E+01 /
29628       DATA (AM( 4,K,-5),K=0, 2)
29629      & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
29630       DATA (AM( 5,K,-5),K=0, 2)
29631      & /  0.2193195E+02, -0.1788518E+02,  0.9460908E+01 /
29632       DATA (AM( 6,K,-5),K=0, 2)
29633      & / -0.1327377E+02,  0.1201754E+02, -0.6277844E+01 /
29634
29635       IF(Q .LE. QMAVEC(IFL)) THEN
29636          PYCT5L = 0.D0
29637          RETURN
29638       ENDIF
29639
29640       IF(X .GE. 1.D0) THEN
29641          PYCT5L = 0.D0
29642          RETURN
29643       ENDIF
29644
29645       TMP = LOG(Q/ALFVEC(IFL))
29646       IF(TMP .LE. 0.D0) THEN
29647          PYCT5L = 0.D0
29648          RETURN
29649       ENDIF
29650
29651       SB = LOG(TMP)
29652       SB1 = SB - 1.2D0
29653       SB2 = SB1*SB1
29654
29655       DO 110 I = 0, NEX
29656          AF(I) = 0.D0
29657          SBX = 1.D0
29658          DO 100 K = 0, MLFVEC(IFL)
29659             AF(I) = AF(I) + SBX*AM(I,K,IFL)
29660             SBX = SB1*SBX
29661   100    CONTINUE
29662   110 CONTINUE
29663
29664       Y = -LOG(X)
29665       U = LOG(X/0.00001D0)
29666
29667       PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29668       PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29669       PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29670       PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29671      &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29672
29673       PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29674
29675 C...Include threshold factor.
29676       PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
29677
29678       RETURN
29679       END
29680
29681 C*********************************************************************
29682
29683 C...PYCT5M
29684 C...Auxiliary function for parametrization of CTEQ5M1.
29685 C...Author: J. Pumplin 9/99.
29686
29687       FUNCTION PYCT5M(IFL,X,Q)
29688
29689 C...Double precision declaration.
29690       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29691       IMPLICIT INTEGER(I-N)
29692
29693       PARAMETER (NEX=8, NLF=2)
29694       DIMENSION AM(0:NEX,0:NLF,-5:2)
29695       DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29696       DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29697       DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29698       DIMENSION AF(0:NEX)
29699
29700       DATA MEXVEC( 2) / 8 /
29701       DATA MLFVEC( 2) / 2 /
29702       DATA UT1VEC( 2) /  0.5141718E+01 /
29703       DATA UT2VEC( 2) / -0.1346944E+01 /
29704       DATA ALFVEC( 2) /  0.5260555E+00 /
29705       DATA QMAVEC( 2) /  0.0000000E+00 /
29706       DATA (AM( 0,K, 2),K=0, 2)
29707      & /  0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
29708       DATA (AM( 1,K, 2),K=0, 2)
29709      & /  0.9839410E+00,  0.4168426E-01, -0.5018952E-01 /
29710       DATA (AM( 2,K, 2),K=0, 2)
29711      & / -0.1651961E+02,  0.9246261E+01,  0.5996400E+01 /
29712       DATA (AM( 3,K, 2),K=0, 2)
29713      & / -0.2077936E+02,  0.9786469E+01,  0.7656465E+01 /
29714       DATA (AM( 4,K, 2),K=0, 2)
29715      & /  0.3054926E+02,  0.1889536E+01,  0.1380541E+01 /
29716       DATA (AM( 5,K, 2),K=0, 2)
29717      & /  0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
29718       DATA (AM( 6,K, 2),K=0, 2)
29719      & / -0.1426778E+02,  0.6239537E+01,  0.5254819E+01 /
29720       DATA (AM( 7,K, 2),K=0, 2)
29721      & / -0.1909811E+02,  0.3695678E+01,  0.5495729E+01 /
29722       DATA (AM( 8,K, 2),K=0, 2)
29723      & /  0.1889751E-01,  0.5027193E-02,  0.6624896E-03 /
29724
29725       DATA MEXVEC( 1) / 8 /
29726       DATA MLFVEC( 1) / 2 /
29727       DATA UT1VEC( 1) /  0.4138426E+01 /
29728       DATA UT2VEC( 1) / -0.3221374E+01 /
29729       DATA ALFVEC( 1) /  0.4960962E+00 /
29730       DATA QMAVEC( 1) /  0.0000000E+00 /
29731       DATA (AM( 0,K, 1),K=0, 2)
29732      & /  0.1332497E+01, -0.3703718E+00,  0.1288638E+00 /
29733       DATA (AM( 1,K, 1),K=0, 2)
29734      & /  0.7544687E+00,  0.3255075E-01, -0.4706680E-01 /
29735       DATA (AM( 2,K, 1),K=0, 2)
29736      & / -0.7638814E+00,  0.5008313E+00, -0.9237374E-01 /
29737       DATA (AM( 3,K, 1),K=0, 2)
29738      & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
29739       DATA (AM( 4,K, 1),K=0, 2)
29740      & /  0.3991610E+02,  0.1979881E+01,  0.1775814E+01 /
29741       DATA (AM( 5,K, 1),K=0, 2)
29742      & /  0.6201080E+01,  0.2046288E+01,  0.3804571E+00 /
29743       DATA (AM( 6,K, 1),K=0, 2)
29744      & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
29745       DATA (AM( 7,K, 1),K=0, 2)
29746      & / -0.8631305E+01, -0.3981200E+01,  0.6970153E+00 /
29747       DATA (AM( 8,K, 1),K=0, 2)
29748      & /  0.2371230E-01,  0.5372683E-02,  0.1118701E-02 /
29749
29750       DATA MEXVEC( 0) / 8 /
29751       DATA MLFVEC( 0) / 2 /
29752       DATA UT1VEC( 0) / -0.1026789E+01 /
29753       DATA UT2VEC( 0) / -0.9051707E+01 /
29754       DATA ALFVEC( 0) /  0.9462977E+00 /
29755       DATA QMAVEC( 0) /  0.0000000E+00 /
29756       DATA (AM( 0,K, 0),K=0, 2)
29757      & /  0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
29758       DATA (AM( 1,K, 0),K=0, 2)
29759      & / -0.9449972E+02,  0.1074771E+01,  0.2056055E+01 /
29760       DATA (AM( 2,K, 0),K=0, 2)
29761      & /  0.3701064E+01, -0.1167947E-02,  0.1933573E+00 /
29762       DATA (AM( 3,K, 0),K=0, 2)
29763      & /  0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
29764       DATA (AM( 4,K, 0),K=0, 2)
29765      & / -0.1014453E+03, -0.5707427E+00,  0.4511242E-01 /
29766       DATA (AM( 5,K, 0),K=0, 2)
29767      & /  0.6365168E+01,  0.1275354E+01, -0.4964081E+00 /
29768       DATA (AM( 6,K, 0),K=0, 2)
29769      & / -0.3370693E+01, -0.1122020E+01,  0.5947751E-01 /
29770       DATA (AM( 7,K, 0),K=0, 2)
29771      & / -0.5327270E+01, -0.9293556E+00,  0.6629940E+00 /
29772       DATA (AM( 8,K, 0),K=0, 2)
29773      & /  0.2437513E-01,  0.1600939E-02,  0.6855336E-03 /
29774
29775       DATA MEXVEC(-1) / 8 /
29776       DATA MLFVEC(-1) / 2 /
29777       DATA UT1VEC(-1) /  0.5243571E+01 /
29778       DATA UT2VEC(-1) / -0.2870513E+01 /
29779       DATA ALFVEC(-1) /  0.6701448E+00 /
29780       DATA QMAVEC(-1) /  0.0000000E+00 /
29781       DATA (AM( 0,K,-1),K=0, 2)
29782      & /  0.2428863E+02,  0.1907035E+01, -0.4606457E+00 /
29783       DATA (AM( 1,K,-1),K=0, 2)
29784      & /  0.2006810E+01, -0.1265915E+00,  0.7153556E-02 /
29785       DATA (AM( 2,K,-1),K=0, 2)
29786      & / -0.1884546E+02, -0.2339471E+01,  0.5740679E+01 /
29787       DATA (AM( 3,K,-1),K=0, 2)
29788      & / -0.2527892E+02, -0.2044124E+01,  0.1280470E+02 /
29789       DATA (AM( 4,K,-1),K=0, 2)
29790      & / -0.1013824E+03, -0.1594199E+01,  0.2216401E+00 /
29791       DATA (AM( 5,K,-1),K=0, 2)
29792      & /  0.8070930E+02,  0.1792072E+01, -0.2164364E+02 /
29793       DATA (AM( 6,K,-1),K=0, 2)
29794      & / -0.4641050E+02,  0.1977338E+00,  0.1273014E+02 /
29795       DATA (AM( 7,K,-1),K=0, 2)
29796      & / -0.3910568E+02,  0.1719632E+01,  0.1086525E+02 /
29797       DATA (AM( 8,K,-1),K=0, 2)
29798      & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
29799
29800       DATA MEXVEC(-2) / 7 /
29801       DATA MLFVEC(-2) / 2 /
29802       DATA UT1VEC(-2) /  0.4782210E+01 /
29803       DATA UT2VEC(-2) / -0.1976856E+02 /
29804       DATA ALFVEC(-2) /  0.7558374E+00 /
29805       DATA QMAVEC(-2) /  0.0000000E+00 /
29806       DATA (AM( 0,K,-2),K=0, 2)
29807      & / -0.6216935E+00,  0.2369963E+00, -0.7909949E-02 /
29808       DATA (AM( 1,K,-2),K=0, 2)
29809      & /  0.1245440E+01, -0.1031510E+00,  0.4916523E-02 /
29810       DATA (AM( 2,K,-2),K=0, 2)
29811      & / -0.7060824E+01, -0.3875283E-01,  0.1784981E+00 /
29812       DATA (AM( 3,K,-2),K=0, 2)
29813      & / -0.7430595E+01,  0.1964572E+00, -0.1284999E+00 /
29814       DATA (AM( 4,K,-2),K=0, 2)
29815      & / -0.6897810E+01,  0.2620543E+01,  0.8012553E-02 /
29816       DATA (AM( 5,K,-2),K=0, 2)
29817      & /  0.1507713E+02,  0.2340307E-01,  0.2482535E+01 /
29818       DATA (AM( 6,K,-2),K=0, 2)
29819      & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
29820       DATA (AM( 7,K,-2),K=0, 2)
29821      & / -0.2571932E+02,  0.2903941E+00, -0.2848206E+01 /
29822
29823       DATA MEXVEC(-3) / 7 /
29824       DATA MLFVEC(-3) / 2 /
29825       DATA UT1VEC(-3) /  0.4518239E+01 /
29826       DATA UT2VEC(-3) / -0.2690590E+01 /
29827       DATA ALFVEC(-3) /  0.6124079E+00 /
29828       DATA QMAVEC(-3) /  0.0000000E+00 /
29829       DATA (AM( 0,K,-3),K=0, 2)
29830      & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
29831       DATA (AM( 1,K,-3),K=0, 2)
29832      & /  0.2927174E+01,  0.4822709E+00, -0.1088787E-01 /
29833       DATA (AM( 2,K,-3),K=0, 2)
29834      & / -0.1771017E+02, -0.1416635E+01,  0.8467622E+01 /
29835       DATA (AM( 3,K,-3),K=0, 2)
29836      & / -0.4972782E+02, -0.3348547E+01,  0.1767061E+02 /
29837       DATA (AM( 4,K,-3),K=0, 2)
29838      & / -0.7102770E+01, -0.3205337E+01,  0.4101704E+00 /
29839       DATA (AM( 5,K,-3),K=0, 2)
29840      & /  0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
29841       DATA (AM( 6,K,-3),K=0, 2)
29842      & / -0.4090347E+02,  0.2103486E+01,  0.1416507E+02 /
29843       DATA (AM( 7,K,-3),K=0, 2)
29844      & / -0.2952639E+02,  0.5376136E+01,  0.7825585E+01 /
29845
29846       DATA MEXVEC(-4) / 7 /
29847       DATA MLFVEC(-4) / 2 /
29848       DATA UT1VEC(-4) /  0.2783230E+01 /
29849       DATA UT2VEC(-4) / -0.1746328E+01 /
29850       DATA ALFVEC(-4) /  0.1115653E+01 /
29851       DATA QMAVEC(-4) /  0.1300000E+01 /
29852       DATA (AM( 0,K,-4),K=0, 2)
29853      & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
29854       DATA (AM( 1,K,-4),K=0, 2)
29855      & /  0.3345755E+01,  0.3187765E+00,  0.1378124E+00 /
29856       DATA (AM( 2,K,-4),K=0, 2)
29857      & / -0.2037615E+02,  0.4121687E+01,  0.2236520E+00 /
29858       DATA (AM( 3,K,-4),K=0, 2)
29859      & / -0.4703104E+02,  0.5353087E+01, -0.1455347E+01 /
29860       DATA (AM( 4,K,-4),K=0, 2)
29861      & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
29862       DATA (AM( 5,K,-4),K=0, 2)
29863      & /  0.5088892E+02, -0.8197304E+01,  0.8083451E+01 /
29864       DATA (AM( 6,K,-4),K=0, 2)
29865      & / -0.2819070E+02,  0.4554086E+01, -0.5890995E+01 /
29866       DATA (AM( 7,K,-4),K=0, 2)
29867      & / -0.1098238E+02,  0.2590096E+01, -0.8062879E+01 /
29868
29869       DATA MEXVEC(-5) / 6 /
29870       DATA MLFVEC(-5) / 2 /
29871       DATA UT1VEC(-5) /  0.1619654E+02 /
29872       DATA UT2VEC(-5) / -0.3367346E+01 /
29873       DATA ALFVEC(-5) /  0.5109891E-02 /
29874       DATA QMAVEC(-5) /  0.4500000E+01 /
29875       DATA (AM( 0,K,-5),K=0, 2)
29876      & / -0.6800138E+01,  0.2493627E+01, -0.1075724E+01 /
29877       DATA (AM( 1,K,-5),K=0, 2)
29878      & /  0.3036555E+01,  0.3324733E+00,  0.2008298E+00 /
29879       DATA (AM( 2,K,-5),K=0, 2)
29880      & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
29881       DATA (AM( 3,K,-5),K=0, 2)
29882      & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
29883       DATA (AM( 4,K,-5),K=0, 2)
29884      & / -0.1099444E+02,  0.1320930E+01, -0.2353831E+01 /
29885       DATA (AM( 5,K,-5),K=0, 2)
29886      & /  0.1699299E+02, -0.3565802E+02,  0.3566872E+02 /
29887       DATA (AM( 6,K,-5),K=0, 2)
29888      & / -0.1465793E+02,  0.2703365E+02, -0.2176372E+02 /
29889
29890       IF(Q .LE. QMAVEC(IFL)) THEN
29891          PYCT5M = 0.D0
29892          RETURN
29893       ENDIF
29894
29895       IF(X .GE. 1.D0) THEN
29896          PYCT5M = 0.D0
29897          RETURN
29898       ENDIF
29899
29900       TMP = LOG(Q/ALFVEC(IFL))
29901       IF(TMP .LE. 0.D0) THEN
29902          PYCT5M = 0.D0
29903          RETURN
29904       ENDIF
29905
29906       SB = LOG(TMP)
29907       SB1 = SB - 1.2D0
29908       SB2 = SB1*SB1
29909
29910       DO 110 I = 0, NEX
29911          AF(I) = 0.D0
29912          SBX = 1.D0
29913          DO 100 K = 0, MLFVEC(IFL)
29914             AF(I) = AF(I) + SBX*AM(I,K,IFL)
29915             SBX = SB1*SBX
29916   100    CONTINUE
29917   110 CONTINUE
29918
29919       Y = -LOG(X)
29920       U = LOG(X/0.00001D0)
29921
29922       PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29923       PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29924       PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29925       PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29926      &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29927
29928       PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29929
29930 C...Include threshold factor.
29931       PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
29932
29933       RETURN
29934       END
29935
29936 C*********************************************************************
29937
29938 C...PYPDPO
29939 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
29940 C...a few older parametrizations, now obsolete but convenient for
29941 C...backwards checks.
29942
29943       SUBROUTINE PYPDPO(X,Q2,XPPR)
29944
29945 C...Double precision and integer declarations.
29946       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29947       IMPLICIT INTEGER(I-N)
29948       INTEGER PYK,PYCHGE,PYCOMP
29949 C...Commonblocks.
29950       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29951       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29952       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29953       COMMON/PYINT1/MINT(400),VINT(400)
29954       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29955       DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
29956      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
29957
29958
29959 C...The following data lines are coefficients needed in the
29960 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
29961 C...parametrizations, see below.
29962 C...Powers of 1-x in different cases.
29963       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
29964 C...Expansion coefficients for up valence quark distribution.
29965       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
29966      1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
29967      2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
29968      3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
29969      4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
29970      5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
29971      6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
29972      1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
29973      2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
29974      3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
29975      4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
29976      5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
29977      6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
29978       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
29979      1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
29980      2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
29981      3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
29982      4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
29983      5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
29984      6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
29985      1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
29986      2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
29987      3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
29988      4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
29989      5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
29990      6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
29991 C...Expansion coefficients for down valence quark distribution.
29992       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
29993      1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
29994      2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
29995      3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
29996      4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
29997      5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
29998      6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
29999      1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30000      2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30001      3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30002      4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30003      5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30004      6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30005       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30006      1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30007      2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30008      3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30009      4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30010      5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30011      6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30012      1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30013      2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30014      3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30015      4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30016      5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30017      6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30018 C...Expansion coefficients for up and down sea quark distributions.
30019       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30020      1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30021      2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30022      3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30023      4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30024      5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30025      6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30026      1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30027      2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30028      3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30029      4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30030      5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30031      6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30032       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30033      1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30034      2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30035      3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30036      4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30037      5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30038      6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30039      1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30040      2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
30041      3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
30042      4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
30043      5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
30044      6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
30045 C...Expansion coefficients for gluon distribution.
30046       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
30047      1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
30048      2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
30049      3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
30050      4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
30051      5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
30052      6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
30053      1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
30054      2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
30055      3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
30056      4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
30057      5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
30058      6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
30059       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
30060      1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
30061      2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
30062      3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
30063      4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
30064      5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
30065      6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
30066      1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
30067      2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
30068      3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
30069      4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
30070      5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
30071      6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
30072 C...Expansion coefficients for strange sea quark distribution.
30073       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
30074      1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
30075      2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
30076      3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
30077      4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
30078      5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
30079      6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
30080      1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
30081      2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
30082      3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
30083      4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
30084      5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
30085      6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
30086       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
30087      1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
30088      2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
30089      3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
30090      4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
30091      5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
30092      6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
30093      1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
30094      2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
30095      3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
30096      4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
30097      5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
30098      6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
30099 C...Expansion coefficients for charm sea quark distribution.
30100       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
30101      1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
30102      2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
30103      3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
30104      4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
30105      5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
30106      6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
30107      1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
30108      2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
30109      3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
30110      4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
30111      5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
30112      6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
30113       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
30114      1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
30115      2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
30116      3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
30117      4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
30118      5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
30119      6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
30120      1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
30121      2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
30122      3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
30123      4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
30124      5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
30125      6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
30126 C...Expansion coefficients for bottom sea quark distribution.
30127       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
30128      1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
30129      2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
30130      3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
30131      4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
30132      5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
30133      6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
30134      1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
30135      2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
30136      3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
30137      4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
30138      5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
30139      6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
30140       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
30141      1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
30142      2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
30143      3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
30144      4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
30145      5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
30146      6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
30147      1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
30148      2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
30149      3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
30150      4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
30151      5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
30152      6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
30153 C...Expansion coefficients for top sea quark distribution.
30154       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
30155      1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
30156      2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
30157      3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
30158      4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30159      5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
30160      6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30161      1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
30162      2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
30163      3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
30164      4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
30165      5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
30166      6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
30167       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
30168      1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
30169      2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
30170      3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
30171      4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30172      5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
30173      6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30174      1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
30175      2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
30176      3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
30177      4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
30178      5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
30179      6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
30180
30181 C...The following data lines are coefficients needed in the
30182 C...Duke, Owens proton structure function parametrizations, see below.
30183 C...Expansion coefficients for (up+down) valence quark distribution.
30184       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
30185      1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30186      2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30187      3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30188       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
30189      1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30190      2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30191      3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30192 C...Expansion coefficients for down valence quark distribution.
30193       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
30194      1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30195      2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30196      3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30197       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
30198      1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30199      2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30200      3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30201 C...Expansion coefficients for (up+down+strange) sea quark distribution.
30202       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
30203      1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30204      2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
30205      3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
30206       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
30207      1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30208      2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
30209      3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
30210 C...Expansion coefficients for charm sea quark distribution.
30211       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
30212      1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30213      2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
30214      3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
30215        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
30216      1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30217      2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
30218      3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
30219 C...Expansion coefficients for gluon distribution.
30220       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
30221      1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30222      2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
30223      3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
30224       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
30225      1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30226      2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
30227      3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
30228
30229 C...Euler's beta function, requires ordinary Gamma function
30230       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
30231
30232 C...Leading order proton parton distributions from Glueck, Reya and
30233 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
30234 C...10^-5 < x < 1.
30235       IF(MSTP(51).EQ.11) THEN
30236
30237 C...Determine s expansion variable and some x expressions.
30238         Q2IN=MIN(1D8,MAX(0.25D0,Q2))
30239         SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
30240         SD2=SD**2
30241         XL=-LOG(X)
30242         XS=SQRT(X)
30243
30244 C...Evaluate valence, gluon and sea distributions.
30245         XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
30246      &  X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
30247      &  (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
30248      &  (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
30249         XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
30250      &  (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
30251      &  1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
30252         XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
30253      &  (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
30254      &  1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
30255      &  SQRT(4.066D0*SD**1.218D0*XL)))*
30256      &  (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
30257         XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
30258      &  1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
30259      &  SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
30260      &  XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
30261         XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
30262      &  (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
30263      &  EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
30264      &  SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
30265         IF(SD.LE.0.888D0) THEN
30266           XFCHM=0D0
30267         ELSE
30268           XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
30269      &    (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
30270      &    SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
30271         ENDIF
30272         IF(SD.LE.1.351D0) THEN
30273           XFBOT=0D0
30274         ELSE
30275           XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
30276      &    1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
30277      &    SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
30278         ENDIF
30279
30280 C...Put into output array.
30281         XPPR(0)=XFGLU
30282         XPPR(1)=XFVDD+XFSEA
30283         XPPR(2)=XFVUD-XFVDD+XFSEA
30284         XPPR(3)=XFSTR
30285         XPPR(4)=XFCHM
30286         XPPR(5)=XFBOT
30287         XPPR(-1)=XFSEA
30288         XPPR(-2)=XFSEA
30289         XPPR(-3)=XFSTR
30290         XPPR(-4)=XFCHM
30291         XPPR(-5)=XFBOT
30292
30293 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
30294 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
30295       ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
30296
30297 C...Determine set, Lambda and x and t expansion variables.
30298         NSET=MSTP(51)-11
30299         IF(NSET.EQ.1) ALAM=0.2D0
30300         IF(NSET.EQ.2) ALAM=0.29D0
30301         TMIN=LOG(5D0/ALAM**2)
30302         TMAX=LOG(1D8/ALAM**2)
30303         T=LOG(MAX(1D0,Q2/ALAM**2))
30304         VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30305         NX=1
30306         IF(X.LE.0.1D0) NX=2
30307         IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
30308         IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
30309
30310 C...Chebyshev polynomials for x and t expansion.
30311         TX(1)=1D0
30312         TX(2)=VX
30313         TX(3)=2D0*VX**2-1D0
30314         TX(4)=4D0*VX**3-3D0*VX
30315         TX(5)=8D0*VX**4-8D0*VX**2+1D0
30316         TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
30317         TT(1)=1D0
30318         TT(2)=VT
30319         TT(3)=2D0*VT**2-1D0
30320         TT(4)=4D0*VT**3-3D0*VT
30321         TT(5)=8D0*VT**4-8D0*VT**2+1D0
30322         TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30323
30324 C...Calculate structure functions.
30325         DO 120 KFL=1,6
30326           XQSUM=0D0
30327           DO 110 IT=1,6
30328             DO 100 IX=1,6
30329               XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
30330   100       CONTINUE
30331   110     CONTINUE
30332           XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
30333   120   CONTINUE
30334
30335 C...Put into output array.
30336         XPPR(0)=XQ(4)
30337         XPPR(1)=XQ(2)+XQ(3)
30338         XPPR(2)=XQ(1)+XQ(3)
30339         XPPR(3)=XQ(5)
30340         XPPR(4)=XQ(6)
30341         XPPR(-1)=XQ(3)
30342         XPPR(-2)=XQ(3)
30343         XPPR(-3)=XQ(5)
30344         XPPR(-4)=XQ(6)
30345
30346 C...Special expansion for bottom (threshold effects).
30347         IF(MSTP(58).GE.5) THEN
30348           IF(NSET.EQ.1) TMIN=8.1905D0
30349           IF(NSET.EQ.2) TMIN=7.4474D0
30350           IF(T.GT.TMIN) THEN
30351             VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30352             TT(1)=1D0
30353             TT(2)=VT
30354             TT(3)=2D0*VT**2-1D0
30355             TT(4)=4D0*VT**3-3D0*VT
30356             TT(5)=8D0*VT**4-8D0*VT**2+1D0
30357             TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30358             XQSUM=0D0
30359             DO 140 IT=1,6
30360               DO 130 IX=1,6
30361                 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
30362   130         CONTINUE
30363   140       CONTINUE
30364             XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
30365             XPPR(-5)=XPPR(5)
30366           ENDIF
30367         ENDIF
30368
30369 C...Special expansion for top (threshold effects).
30370         IF(MSTP(58).GE.6) THEN
30371           IF(NSET.EQ.1) TMIN=11.5528D0
30372           IF(NSET.EQ.2) TMIN=10.8097D0
30373           TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
30374           TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
30375           IF(T.GT.TMIN) THEN
30376             VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30377             TT(1)=1D0
30378             TT(2)=VT
30379             TT(3)=2D0*VT**2-1D0
30380             TT(4)=4D0*VT**3-3D0*VT
30381             TT(5)=8D0*VT**4-8D0*VT**2+1D0
30382             TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30383             XQSUM=0D0
30384             DO 160 IT=1,6
30385               DO 150 IX=1,6
30386                 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
30387   150         CONTINUE
30388   160       CONTINUE
30389             XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
30390             XPPR(-6)=XPPR(6)
30391           ENDIF
30392         ENDIF
30393
30394 C...Proton parton distributions from Duke, Owens.
30395 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
30396       ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
30397
30398 C...Determine set, Lambda and s expansion parameter.
30399         NSET=MSTP(51)-13
30400         IF(NSET.EQ.1) ALAM=0.2D0
30401         IF(NSET.EQ.2) ALAM=0.4D0
30402         Q2IN=MIN(1D6,MAX(4D0,Q2))
30403         SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
30404
30405 C...Calculate structure functions.
30406         DO 180 KFL=1,5
30407           DO 170 IS=1,6
30408             TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
30409      &      CDO(3,IS,KFL,NSET)*SD**2
30410   170     CONTINUE
30411           IF(KFL.LE.2) THEN
30412             XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
30413      &      TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
30414           ELSE
30415             XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
30416      &      TS(5)*X**2+TS(6)*X**3)
30417           ENDIF
30418   180   CONTINUE
30419
30420 C...Put into output arrays.
30421         XPPR(0)=XQ(5)
30422         XPPR(1)=XQ(2)+XQ(3)/6D0
30423         XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
30424         XPPR(3)=XQ(3)/6D0
30425         XPPR(4)=XQ(4)
30426         XPPR(-1)=XQ(3)/6D0
30427         XPPR(-2)=XQ(3)/6D0
30428         XPPR(-3)=XQ(3)/6D0
30429         XPPR(-4)=XQ(4)
30430
30431       ENDIF
30432
30433       RETURN
30434       END
30435
30436 C*********************************************************************
30437
30438 C...PYHFTH
30439 C...Gives threshold attractive/repulsive factor for heavy flavour
30440 C...production.
30441
30442       FUNCTION PYHFTH(SH,SQM,FRATT)
30443
30444 C...Double precision and integer declarations.
30445       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30446       IMPLICIT INTEGER(I-N)
30447       INTEGER PYK,PYCHGE,PYCOMP
30448 C...Commonblocks.
30449       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30450       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30451       COMMON/PYINT1/MINT(400),VINT(400)
30452       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
30453
30454 C...Value for alpha_strong.
30455       IF(MSTP(35).LE.1) THEN
30456         ALSSG=PARP(35)
30457       ELSE
30458         MST115=MSTU(115)
30459         MSTU(115)=MSTP(36)
30460         Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
30461      &  PARP(36)**2)))
30462         ALSSG=PYALPS(Q2BN)
30463         MSTU(115)=MST115
30464       ENDIF
30465
30466 C...Evaluate attractive and repulsive factors.
30467       XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30468       FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
30469       XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30470       FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
30471       PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
30472       VINT(138)=PYHFTH
30473
30474       RETURN
30475       END
30476
30477 C*********************************************************************
30478
30479 C...PYSPLI
30480 C...Splits a hadron remnant into two (partons or hadron + parton)
30481 C...in case it is more complicated than just a quark or a diquark.
30482
30483       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
30484
30485 C...Double precision and integer declarations.
30486       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30487       IMPLICIT INTEGER(I-N)
30488       INTEGER PYK,PYCHGE,PYCOMP
30489 C...Commonblocks. PYDAT1 temporary
30490       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30491       COMMON/PYINT1/MINT(400),VINT(400)
30492       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30493       SAVE /PYPARS/,/PYINT1/,/PYDAT1/
30494 C...Local array.
30495       DIMENSION KFL(3)
30496
30497 C...Preliminaries. Parton composition.
30498       KFA=IABS(KF)
30499       KFS=ISIGN(1,KF)
30500       KFL(1)=MOD(KFA/1000,10)
30501       KFL(2)=MOD(KFA/100,10)
30502       KFL(3)=MOD(KFA/10,10)
30503       IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
30504         KFL(2)=INT(1.5D0+PYR(0))
30505         IF(MINT(105).EQ.333) KFL(2)=3
30506         IF(MINT(105).EQ.443) KFL(2)=4
30507         KFL(3)=KFL(2)
30508       ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
30509         KFL(2)=2
30510         KFL(3)=2
30511       ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
30512         KFL(2)=1
30513         KFL(3)=1
30514       ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
30515         KFL(2)=MOD(KFA/10,10)
30516         KFL(3)=MOD(KFA/100,10)
30517       ENDIF
30518       IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
30519         KFLR=KFLIN*KFS
30520       ELSE
30521         KFLR=KFLIN
30522       ENDIF
30523       KFLCH=0
30524
30525 C...Subdivide lepton.
30526       IF(KFA.GE.11.AND.KFA.LE.18) THEN
30527         IF(KFLR.EQ.KFA) THEN
30528           KFLSP=KFS*22
30529         ELSEIF(KFLR.EQ.22) THEN
30530           KFLSP=KFA
30531         ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
30532           KFLSP=KFA+1
30533         ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
30534           KFLSP=KFA-1
30535         ELSEIF(KFLR.EQ.21) THEN
30536           KFLSP=KFA
30537           KFLCH=KFS*21
30538         ELSE
30539           KFLSP=KFA
30540           KFLCH=-KFLR
30541         ENDIF
30542
30543 C...Subdivide photon.
30544       ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
30545         IF(KFLR.NE.21) THEN
30546           KFLSP=-KFLR
30547         ELSE
30548           RAGR=0.75D0*PYR(0)
30549           KFLSP=1
30550           IF(RAGR.GT.0.125D0) KFLSP=2
30551           IF(RAGR.GT.0.625D0) KFLSP=3
30552           IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
30553           KFLCH=-KFLSP
30554         ENDIF
30555
30556 C...Subdivide Reggeon or Pomeron.
30557       ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
30558         IF(KFLIN.EQ.21) THEN
30559           KFLSP=KFS*21
30560         ELSE
30561           KFLSP=-KFLIN
30562         ENDIF
30563
30564 C...Subdivide meson.
30565       ELSEIF(KFL(1).EQ.0) THEN
30566         KFL(2)=KFL(2)*(-1)**KFL(2)
30567         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
30568         IF(KFLR.EQ.KFL(2)) THEN
30569           KFLSP=KFL(3)
30570         ELSEIF(KFLR.EQ.KFL(3)) THEN
30571           KFLSP=KFL(2)
30572         ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
30573           KFLSP=KFL(2)
30574           KFLCH=KFL(3)
30575         ELSEIF(KFLR.EQ.21) THEN
30576           KFLSP=KFL(3)
30577           KFLCH=KFL(2)
30578         ELSEIF(KFLR*KFL(2).GT.0) THEN
30579           NTRY=0
30580   100     NTRY=NTRY+1
30581           CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
30582           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30583             GOTO 100
30584           ELSEIF(KFLCH.EQ.0) THEN
30585             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30586             MINT(51)=1
30587             RETURN
30588           ENDIF
30589           KFLSP=KFL(3)
30590         ELSE
30591           NTRY=0
30592   110     NTRY=NTRY+1
30593           CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
30594           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30595             GOTO 110
30596           ELSEIF(KFLCH.EQ.0) THEN
30597             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30598             MINT(51)=1
30599             RETURN
30600           ENDIF
30601           KFLSP=KFL(2)
30602         ENDIF
30603
30604 C...Subdivide baryon.
30605       ELSE
30606         NAGR=0
30607         DO 120 J=1,3
30608           IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
30609   120   CONTINUE
30610         IF(NAGR.GE.1) THEN
30611           RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
30612           IAGR=0
30613           DO 130 J=1,3
30614             IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
30615             IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
30616   130     CONTINUE
30617         ELSE
30618           IAGR=1.00001D0+2.99998D0*PYR(0)
30619         ENDIF
30620         ID1=1
30621         IF(IAGR.EQ.1) ID1=2
30622         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
30623         ID2=6-IAGR-ID1
30624         KSP=3
30625         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
30626           IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
30627         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
30628           IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
30629         ELSEIF(MOD(KFA,10).EQ.2) THEN
30630           IF(IAGR.EQ.1) KSP=1
30631           IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
30632         ENDIF
30633         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
30634         IF(KFLR.EQ.21) THEN
30635           KFLCH=KFL(IAGR)
30636         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
30637           NTRY=0
30638   140     NTRY=NTRY+1
30639           CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
30640           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30641             GOTO 140
30642           ELSEIF(KFLCH.EQ.0) THEN
30643             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30644             MINT(51)=1
30645             RETURN
30646           ENDIF
30647         ELSEIF(NAGR.EQ.0) THEN
30648           NTRY=0
30649   150     NTRY=NTRY+1
30650           CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
30651           IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30652             GOTO 150
30653           ELSEIF(KFLCH.EQ.0) THEN
30654             CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30655             MINT(51)=1
30656             RETURN
30657           ENDIF
30658           KFLSP=KFL(IAGR)
30659         ENDIF
30660       ENDIF
30661
30662 C...Add on correct sign for result.
30663       KFLCH=KFLCH*KFS
30664       KFLSP=KFLSP*KFS
30665
30666       RETURN
30667       END
30668
30669 C*********************************************************************
30670
30671 C...PYGAMM
30672 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
30673 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
30674 C...(Dover, 1965) 6.1.36.
30675
30676       FUNCTION PYGAMM(X)
30677
30678 C...Double precision and integer declarations.
30679       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30680       IMPLICIT INTEGER(I-N)
30681       INTEGER PYK,PYCHGE,PYCOMP
30682 C...Local array and data.
30683       DIMENSION B(8)
30684       DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
30685      &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
30686
30687       NX=INT(X)
30688       DX=X-NX
30689
30690       PYGAMM=1D0
30691       DXP=1D0
30692       DO 100 I=1,8
30693         DXP=DXP*DX
30694         PYGAMM=PYGAMM+B(I)*DXP
30695   100 CONTINUE
30696       IF(X.LT.1D0) THEN
30697         PYGAMM=PYGAMM/X
30698       ELSE
30699         DO 110 IX=1,NX-1
30700           PYGAMM=(X-IX)*PYGAMM
30701   110   CONTINUE
30702       ENDIF
30703
30704       RETURN
30705       END
30706
30707 C***********************************************************************
30708
30709 C...PYWAUX
30710 C...Calculates real and imaginary parts of the auxiliary functions W1
30711 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
30712 C...der Bij, Nucl. Phys. B297 (1988) 221.
30713
30714       SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
30715
30716 C...Double precision and integer declarations.
30717       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30718       IMPLICIT INTEGER(I-N)
30719       INTEGER PYK,PYCHGE,PYCOMP
30720 C...Commonblocks.
30721       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30722       SAVE /PYDAT1/
30723
30724       ASINH(X)=LOG(X+SQRT(X**2+1D0))
30725       ACOSH(X)=LOG(X+SQRT(X**2-1D0))
30726
30727       IF(EPS.LT.0D0) THEN
30728         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
30729         IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
30730         WIM=0D0
30731       ELSEIF(EPS.LT.1D0) THEN
30732         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
30733         IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
30734         IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
30735         IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
30736       ELSE
30737         IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
30738         IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
30739         WIM=0D0
30740       ENDIF
30741
30742       RETURN
30743       END
30744
30745 C***********************************************************************
30746
30747 C...PYI3AU
30748 C...Calculates real and imaginary parts of the auxiliary function I3;
30749 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
30750 C...Nucl. Phys. B297 (1988) 221.
30751
30752       SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
30753
30754 C...Double precision and integer declarations.
30755       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30756       IMPLICIT INTEGER(I-N)
30757       INTEGER PYK,PYCHGE,PYCOMP
30758 C...Commonblocks.
30759       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30760       SAVE /PYDAT1/
30761
30762       BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
30763       IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
30764
30765       IF(EPS.LT.0D0) THEN
30766         IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30767           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30768      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30769      &    PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
30770      &    PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
30771      &    LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
30772      &    LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
30773      &    LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
30774      &    EPS))
30775         ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30776           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30777      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30778      &    PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
30779      &    PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
30780      &    0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
30781      &    LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
30782      &    LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
30783         ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30784           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30785      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30786      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
30787      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
30788      &    0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
30789      &    LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
30790      &    LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
30791         ELSE
30792           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30793      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
30794      &    PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
30795      &    LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
30796      &    LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
30797         ENDIF
30798         F3IM=0D0
30799       ELSEIF(EPS.LT.1D0) THEN
30800         IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30801           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30802      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30803      &    PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
30804      &    PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
30805      &    (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30806      &    (0.25D0*(RAT+1D0)*EPS))
30807           F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30808      &    (0.25D0*(RAT+1D0)*EPS))
30809         ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30810           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30811      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30812      &    PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
30813      &    PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
30814      &    LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
30815      &    LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30816           F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30817         ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30818           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30819      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30820      &    PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
30821      &    PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
30822      &    LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
30823      &    (1D0+0.25D0*RAT*EPS-GA))
30824           F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
30825      &    (1D0+0.25D0*RAT*EPS-GA))
30826         ELSE
30827           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30828      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
30829      &    PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
30830      &    LOG((GA+BE-1D0)/(BE-GA))
30831           F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
30832         ENDIF
30833       ELSE
30834         RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
30835         RCTHE=RSQ*(1D0-2D0*BE/EPS)
30836         RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
30837         RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
30838         RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
30839         R=SQRT(RSQ)
30840         THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
30841         PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
30842         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
30843      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
30844      &  (PHI-THE)*(PHI+THE-PARU(1))
30845         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
30846      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
30847       ENDIF
30848
30849       Y3RE=2D0/(2D0*BE-1D0)*F3RE
30850       Y3IM=2D0/(2D0*BE-1D0)*F3IM
30851
30852       RETURN
30853       END
30854
30855 C***********************************************************************
30856
30857 C...PYSPEN
30858 C...Calculates real and imaginary part of Spence function; see
30859 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
30860
30861       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
30862
30863 C...Double precision and integer declarations.
30864       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30865       IMPLICIT INTEGER(I-N)
30866       INTEGER PYK,PYCHGE,PYCOMP
30867 C...Commonblocks.
30868       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30869       SAVE /PYDAT1/
30870 C...Local array and data.
30871       DIMENSION B(0:14)
30872       DATA B/
30873      &1.000000D+00,        -5.000000D-01,         1.666667D-01,
30874      &0.000000D+00,        -3.333333D-02,         0.000000D+00,
30875      &2.380952D-02,         0.000000D+00,        -3.333333D-02,
30876      &0.000000D+00,         7.575757D-02,         0.000000D+00,
30877      &-2.531135D-01,         0.000000D+00,         1.166667D+00/
30878
30879       XRE=XREIN
30880       XIM=XIMIN
30881       IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
30882         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
30883         IF(IREIM.EQ.2) PYSPEN=0D0
30884         RETURN
30885       ENDIF
30886
30887       XMOD=SQRT(XRE**2+XIM**2)
30888       IF(XMOD.LT.1D-6) THEN
30889         IF(IREIM.EQ.1) PYSPEN=0D0
30890         IF(IREIM.EQ.2) PYSPEN=0D0
30891         RETURN
30892       ENDIF
30893
30894       XARG=SIGN(ACOS(XRE/XMOD),XIM)
30895       SP0RE=0D0
30896       SP0IM=0D0
30897       SGN=1D0
30898       IF(XMOD.GT.1D0) THEN
30899         ALGXRE=LOG(XMOD)
30900         ALGXIM=XARG-SIGN(PARU(1),XARG)
30901         SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
30902         SP0IM=-ALGXRE*ALGXIM
30903         SGN=-1D0
30904         XMOD=1D0/XMOD
30905         XARG=-XARG
30906         XRE=XMOD*COS(XARG)
30907         XIM=XMOD*SIN(XARG)
30908       ENDIF
30909       IF(XRE.GT.0.5D0) THEN
30910         ALGXRE=LOG(XMOD)
30911         ALGXIM=XARG
30912         XRE=1D0-XRE
30913         XIM=-XIM
30914         XMOD=SQRT(XRE**2+XIM**2)
30915         XARG=SIGN(ACOS(XRE/XMOD),XIM)
30916         ALGYRE=LOG(XMOD)
30917         ALGYIM=XARG
30918         SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
30919         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
30920         SGN=-SGN
30921       ENDIF
30922
30923       XRE=1D0-XRE
30924       XIM=-XIM
30925       XMOD=SQRT(XRE**2+XIM**2)
30926       XARG=SIGN(ACOS(XRE/XMOD),XIM)
30927       ZRE=-LOG(XMOD)
30928       ZIM=-XARG
30929
30930       SPRE=0D0
30931       SPIM=0D0
30932       SAVERE=1D0
30933       SAVEIM=0D0
30934       DO 100 I=0,14
30935         IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
30936         TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
30937         TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
30938         SAVERE=TERMRE
30939         SAVEIM=TERMIM
30940         SPRE=SPRE+B(I)*TERMRE
30941         SPIM=SPIM+B(I)*TERMIM
30942   100 CONTINUE
30943
30944   110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
30945       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
30946
30947       RETURN
30948       END
30949
30950 C***********************************************************************
30951
30952 C...PYQQBH
30953 C...Calculates the matrix element for the processes
30954 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
30955 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
30956 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
30957
30958       SUBROUTINE PYQQBH(WTQQBH)
30959
30960 C...Double precision and integer declarations.
30961       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30962       IMPLICIT INTEGER(I-N)
30963       INTEGER PYK,PYCHGE,PYCOMP
30964 C...Commonblocks.
30965       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30966       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30967       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30968       COMMON/PYINT1/MINT(400),VINT(400)
30969       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30970       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
30971 C...Local arrays and function.
30972       DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
30973       DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
30974      &PP(I,3)*PP(J,3)
30975
30976 C...Mass parameters.
30977       WTQQBH=0D0
30978       ISUB=MINT(1)
30979       SHPR=SQRT(VINT(26))*VINT(1)
30980       PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
30981       PH=SQRT(VINT(21))*VINT(1)
30982       SPQ=PQ**2
30983       SPH=PH**2
30984
30985 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
30986       DO 100 I=1,2
30987         PT=SQRT(MAX(0D0,VINT(197+5*I)))
30988         PP(I,1)=PT*COS(VINT(198+5*I))
30989         PP(I,2)=PT*SIN(VINT(198+5*I))
30990   100 CONTINUE
30991       PP(3,1)=-PP(1,1)-PP(2,1)
30992       PP(3,2)=-PP(1,2)-PP(2,2)
30993       PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
30994       PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
30995       PMS3=SPH+PP(3,1)**2+PP(3,2)**2
30996       PMT3=SQRT(PMS3)
30997       PP(3,3)=PMT3*SINH(VINT(211))
30998       PP(3,4)=PMT3*COSH(VINT(211))
30999       PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31000       PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31001      &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31002       PP(2,3)=-PP(1,3)-PP(3,3)
31003       PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31004       PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31005
31006 C...Set up incoming kinematics and derived momentum combinations.
31007       DO 110 I=4,5
31008         PP(I,1)=0D0
31009         PP(I,2)=0D0
31010         PP(I,3)=-0.5D0*SHPR*(-1)**I
31011         PP(I,4)=-0.5D0*SHPR
31012   110 CONTINUE
31013       DO 120 J=1,4
31014         PP(6,J)=PP(1,J)+PP(2,J)
31015         PP(7,J)=PP(1,J)+PP(3,J)
31016         PP(8,J)=PP(1,J)+PP(4,J)
31017         PP(9,J)=PP(1,J)+PP(5,J)
31018         PP(10,J)=-PP(2,J)-PP(3,J)
31019         PP(11,J)=-PP(2,J)-PP(4,J)
31020         PP(12,J)=-PP(2,J)-PP(5,J)
31021         PP(13,J)=-PP(4,J)-PP(5,J)
31022   120 CONTINUE
31023
31024 C...Derived kinematics invariants.
31025       X1=DOT(1,2)
31026       X2=DOT(1,3)
31027       X3=DOT(1,4)
31028       X4=DOT(1,5)
31029       X5=DOT(2,3)
31030       X6=DOT(2,4)
31031       X7=DOT(2,5)
31032       X8=DOT(3,4)
31033       X9=DOT(3,5)
31034       X10=DOT(4,5)
31035
31036 C...Propagators.
31037       SS1=DOT(7,7)-SPQ
31038       SS2=DOT(8,8)-SPQ
31039       SS3=DOT(9,9)-SPQ
31040       SS4=DOT(10,10)-SPQ
31041       SS5=DOT(11,11)-SPQ
31042       SS6=DOT(12,12)-SPQ
31043       SS7=DOT(13,13)
31044       DX(1)=SS1*SS6
31045       DX(2)=SS2*SS6
31046       DX(3)=SS2*SS4
31047       DX(4)=SS1*SS5
31048       DX(5)=SS3*SS5
31049       DX(6)=SS3*SS4
31050       DX(7)=SS7*SS1
31051       DX(8)=SS7*SS4
31052
31053 C...Define colour coefficients for g + g -> Q + Qbar + H.
31054       IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
31055         DO 140 I=1,3
31056           DO 130 J=1,3
31057             CLR(I,J)=16D0/3D0
31058             CLR(I+3,J+3)=16D0/3D0
31059             CLR(I,J+3)=-2D0/3D0
31060             CLR(I+3,J)=-2D0/3D0
31061   130     CONTINUE
31062   140   CONTINUE
31063         DO 160 L=1,2
31064           DO 150 I=1,3
31065             CLR(I,6+L)=-6D0
31066             CLR(I+3,6+L)=6D0
31067             CLR(6+L,I)=-6D0
31068             CLR(6+L,I+3)=6D0
31069   150     CONTINUE
31070   160   CONTINUE
31071         DO 180 K1=1,2
31072           DO 170 K2=1,2
31073             CLR(6+K1,6+K2)=12D0
31074   170     CONTINUE
31075   180   CONTINUE
31076
31077 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
31078         FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
31079      &  X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
31080      &  X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
31081         FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
31082      &  *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
31083      &  X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
31084      &  X10)
31085         FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
31086      &  X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
31087      &  +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31088      &  -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
31089      &  -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
31090      &  X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
31091         FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
31092      &  X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
31093      &  )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
31094      &  4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
31095      &  X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
31096         FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
31097      &  X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31098      &  X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
31099      &  *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
31100      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
31101      &  X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
31102      &  +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
31103      &  X4*X6*X5)
31104         FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
31105      &  X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
31106      &  X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
31107      &  *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
31108      &  +X4*X9*X5+X4*X5**2)
31109         FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
31110      &  PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
31111      &  X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
31112      &  X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
31113      &  X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
31114      &  X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
31115         FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
31116      &  PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
31117      &  2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
31118      &  X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
31119      &  +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
31120      &  X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
31121      &  X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
31122      &  X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
31123      &  X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
31124         FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
31125      &  X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
31126         FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
31127      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
31128      &  X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
31129      &  X6)
31130         FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
31131      &  X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31132      &  X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
31133      &  *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
31134      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
31135      &  *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
31136      &  X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
31137      &  X5+X4*X6*X5)
31138         FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
31139      &  *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
31140      &  2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
31141      &  X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
31142      &  X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
31143      &  *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
31144      &  X6**2)
31145         FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
31146      &  X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
31147      &  X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
31148      &  X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
31149      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
31150      &  X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
31151      &  -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
31152      &  X4*X6*X5)
31153         FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31154      &  2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31155      &  X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
31156      &  X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
31157      &  *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
31158      &  +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31159      &  -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
31160      &  X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
31161      &  X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
31162      &  X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
31163      &  *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
31164         FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31165      &  2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31166      &  X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
31167      &  X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
31168      &  *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
31169      &  X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31170      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
31171      &  X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
31172      &  *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
31173      &  X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
31174      &  X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
31175         FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
31176      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
31177      &  X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
31178         FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
31179      &  X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
31180      &  X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
31181      &  *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
31182      &  +X3*X8*X5+X3*X5**2)
31183         FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
31184      &  X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
31185      &  X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
31186      &  *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
31187      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
31188      &  *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
31189      &  X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
31190      &  X5+X4*X6*X5)
31191         FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
31192      &  X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
31193      &  )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
31194      &  X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
31195      &  X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
31196         FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
31197      &  PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
31198      &  X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
31199      &  X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
31200      &  X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
31201      &  X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
31202      &  X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
31203      &  *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
31204      &  +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
31205         FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
31206      &  PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
31207      &  4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
31208      &  +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
31209      &  X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
31210      &  *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
31211         FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
31212      &  X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
31213      &  X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
31214         FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
31215      &  *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
31216      &  X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
31217      &  X10)
31218         FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
31219      &  X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
31220      &  +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31221      &  -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
31222      &  -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
31223      &  X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
31224         FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
31225      &  *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
31226      &  X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
31227      &  X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
31228      &  X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
31229      &  X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
31230         FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
31231      &  *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
31232      &  +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
31233      &  *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
31234      &  X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
31235      &  *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
31236      &  *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
31237      &  *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
31238      &  X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
31239         FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
31240      &  X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
31241         FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
31242      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
31243      &  X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
31244      &  X7)
31245         FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31246      &  4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31247      &  X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
31248      &  3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
31249      &  2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
31250      &  2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
31251      &  X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
31252      &  *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
31253      &  X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
31254      &  X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
31255      &  *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
31256         FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31257      &  4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31258      &  X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
31259      &  2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
31260      &  X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
31261      &  3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
31262      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
31263      &  X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
31264      &  *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
31265      &  X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
31266      &  X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
31267         FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
31268      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
31269      &  X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
31270         FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
31271      &  *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
31272      &  -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
31273      &  -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
31274      &  7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
31275      &  *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
31276      &  *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
31277      &  **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
31278      &  2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
31279         FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
31280      &  *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
31281      &  X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
31282      &  X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
31283      &  *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
31284      &  X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
31285         FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
31286      &  X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
31287      &  X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
31288      &  *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
31289      &  *X6)
31290         FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
31291      &  10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
31292      &  X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
31293      &  X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
31294      &  X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
31295      &  +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
31296      &  7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
31297         FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
31298      &  *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
31299      &  *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
31300      &  X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
31301      &  X8)
31302         FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31303      &  X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
31304      &  )+2*X2*(-X10*X5+X9*X6+X8*X7)
31305         FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31306      &  X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
31307      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
31308      &  X9*X5)
31309         FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31310      &  X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
31311      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
31312      &  X8*X5)
31313         FM(9,10)=0.5D0*(FMXX+FM(9,10))
31314         FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31315      &  X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
31316      &  )+2*X5*(-X10*X2+X9*X3+X8*X4)
31317
31318 C...Repackage matrix elements.
31319         DO 200 I=1,8
31320           DO 190 J=1,8
31321             RM(I,J)=FM(I,J)
31322   190     CONTINUE
31323   200   CONTINUE
31324         RM(7,7)=FM(7,7)-2D0*FM(9,9)
31325         RM(7,8)=FM(7,8)-2D0*FM(9,10)
31326         RM(8,8)=FM(8,8)-2D0*FM(10,10)
31327
31328 C...Produce final result: matrix elements * colours * propagators.
31329         DO 220 I=1,8
31330           DO 210 J=I,8
31331             FAC=8D0
31332             IF(I.EQ.J)FAC=4D0
31333             WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
31334   210     CONTINUE
31335   220   CONTINUE
31336         WTQQBH=-WTQQBH/256D0
31337
31338       ELSE
31339 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
31340         A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
31341      &  *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
31342      &  *X6+X8*X7)
31343         A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
31344      &  2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
31345      &  +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
31346      &  X5)
31347         A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
31348      &  X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
31349      &  *X9+X4*X8)
31350
31351 C...Produce final result: matrix elements * propagators.
31352         A11=A11/DX(7)**2
31353         A12=A12/(DX(7)*DX(8))
31354         A22=A22/DX(8)**2
31355         WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
31356       ENDIF
31357
31358       RETURN
31359       END
31360
31361 C*********************************************************************
31362
31363 C...PYMSIN
31364 C...Initializes supersymmetry: finds sparticle masses and
31365 C...branching ratios and stores this information.
31366 C...AUTHOR: STEPHEN MRENNA
31367
31368       SUBROUTINE PYMSIN
31369
31370 C...Double precision and integer declarations.
31371       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31372       IMPLICIT INTEGER(I-N)
31373       INTEGER PYK,PYCHGE,PYCOMP
31374 C...Parameter statement to help give large particle numbers.
31375       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31376      &KEXCIT=4000000,KDIMEN=5000000)
31377 C...Commonblocks.
31378       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31379       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31380       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31381       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31382       COMMON/PYINT4/MWID(500),WIDS(500,5)
31383       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31384       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
31385       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
31386      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
31387       COMMON/PYHTRI/HHH(7)
31388       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
31389      &/PYMSRV/,/PYSSMT/
31390
31391 C...Local variables.
31392       DOUBLE PRECISION ALFA,BETA
31393       DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
31394       INTEGER I,J,J1,I1,K1
31395       INTEGER KC,LKNT,IDLAM(300,3)
31396       DOUBLE PRECISION XLAM(0:300)
31397       DOUBLE PRECISION WDTP(0:300),WDTE(0:300,0:5)
31398       DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
31399       DOUBLE PRECISION DELM,XMDIF
31400       DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
31401       DOUBLE PRECISION ARG,SGNMU,R
31402       INTEGER IMSSM
31403       INTEGER IRPRTY
31404       INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
31405       SAVE MWIDSU,MDCYSU
31406       DATA KFSUSY/
31407      &1000001,2000001,1000002,2000002,1000003,2000003,
31408      &1000004,2000004,1000005,2000005,1000006,2000006,
31409      &1000011,2000011,1000012,2000012,1000013,2000013,
31410      &1000014,2000014,1000015,2000015,1000016,2000016,
31411      &1000021,1000022,1000023,1000025,1000035,1000024,
31412      &1000037,1000039,     25,     35,     36,     37/
31413       DATA INIT/0/
31414
31415 C...Do nothing if SUSY not requested.
31416       IMSSM=IMSS(1)
31417       IF(IMSSM.EQ.0) RETURN
31418
31419 C...Save copy of MWID(KC) and MDCY(KC,1) values before
31420 C...they are set to zero for the LSP.
31421       IF(INIT.EQ.0) THEN
31422         INIT=1
31423         DO 100 I=1,36
31424           KF=KFSUSY(I)
31425           KC=PYCOMP(KF)
31426           MWIDSU(I)=MWID(KC)
31427           MDCYSU(I)=MDCY(KC,1)
31428   100   CONTINUE
31429       ENDIF
31430
31431 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
31432       DO 110 I=1,36
31433         KF=KFSUSY(I)
31434         KC=PYCOMP(KF)
31435         IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
31436           MWID(KC)=MWIDSU(I)
31437           MDCY(KC,1)=MDCYSU(I)
31438         ENDIF
31439   110 CONTINUE
31440
31441 C...First part of routine: set masses and couplings.
31442
31443 C...Reset mixing values in sfermion sector to pure left/right.
31444       DO 120 I=1,16
31445         SFMIX(I,1)=1D0
31446         SFMIX(I,4)=1D0
31447         SFMIX(I,2)=0D0
31448         SFMIX(I,3)=0D0
31449   120 CONTINUE
31450
31451 C...Common couplings.
31452       TANB=RMSS(5)
31453       BETA=ATAN(TANB)
31454       COSB=COS(BETA)
31455       SINB=TANB*COSB
31456       COS2B=COS(2D0*BETA)
31457       ALFA=RMSS(18)
31458       XMW2=PMAS(24,1)**2
31459       XMZ2=PMAS(23,1)**2
31460       XW=PARU(102)
31461
31462 C...Define sparticle masses for a general MSSM simulation.
31463       IF(IMSSM.EQ.1) THEN
31464         IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
31465         DO 130 I=1,5,2
31466           KC=PYCOMP(KSUSY1+I)
31467           PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
31468           KC=PYCOMP(KSUSY2+I)
31469           PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
31470           KC=PYCOMP(KSUSY1+I+1)
31471           PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
31472           KC=PYCOMP(KSUSY2+I+1)
31473           PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
31474   130   CONTINUE
31475         XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
31476         IF(XARG.LT.0D0) THEN
31477           WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31478      &    ' FROM THE SUM RULE. '
31479           WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
31480           RETURN
31481         ELSE
31482           XARG=SQRT(XARG)
31483         ENDIF
31484         DO 140 I=11,15,2
31485           PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
31486           PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
31487           PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31488           PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
31489   140   CONTINUE
31490         IF(IMSS(8).EQ.1) THEN
31491           RMSS(13)=RMSS(6)
31492           RMSS(14)=RMSS(7)
31493         ENDIF
31494
31495 C...Alternatively derive masses from SUGRA relations.
31496       ELSEIF(IMSSM.EQ.2) THEN
31497         CALL PYAPPS
31498       ENDIF
31499
31500 C...Add in extra D-term contributions.
31501       IF(IMSS(7).EQ.1) THEN
31502         R=0.43D0
31503         DX=RMSS(23)
31504         DY=RMSS(24)
31505         DS=RMSS(25)
31506         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31507         WRITE(MSTU(11),*) 'C  NEW DTERMS ADDED TO SCALAR MASSES   '
31508         WRITE(MSTU(11),*) 'C   IN A U(B-L) THEORY                 '
31509         WRITE(MSTU(11),*) 'C   DX = ',DX
31510         WRITE(MSTU(11),*) 'C   DY = ',DY
31511         WRITE(MSTU(11),*) 'C   DS = ',DS
31512         WRITE(MSTU(11),*) 'C                                      '
31513         DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
31514         WRITE(MSTU(11),*) 'C   DY AT THE WEAK SCALE = ',DY
31515         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31516         DQ2=DY/6D0-DX/3D0-DS/3D0
31517         DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
31518         DD2=DY/3D0+DX-2D0*DS/3D0
31519         DL2=-DY/2D0+DX-2D0*DS/3D0
31520         DE2=DY-DX/3D0-DS/3D0
31521         DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
31522         DHD2=-DY/2D0-2D0*DX/3D0+DS
31523         DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
31524      &  /ABS(COS2B)
31525         DMA2 = 2D0*DMU2+DHU2+DHD2
31526         DO 150 I=1,5,2
31527           KC=PYCOMP(KSUSY1+I)
31528           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31529           KC=PYCOMP(KSUSY2+I)
31530           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
31531           KC=PYCOMP(KSUSY1+I+1)
31532           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31533           KC=PYCOMP(KSUSY2+I+1)
31534           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
31535   150   CONTINUE
31536         DO 160 I=11,15,2
31537           KC=PYCOMP(KSUSY1+I)
31538           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31539           KC=PYCOMP(KSUSY2+I)
31540           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
31541           KC=PYCOMP(KSUSY1+I+1)
31542           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31543   160   CONTINUE
31544         IF(RMSS(4)**2+DMU2.LT.0D0) THEN
31545           WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
31546           STOP
31547         ENDIF
31548         SGNMU=SIGN(1D0,RMSS(4))
31549         RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
31550         ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
31551         RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
31552         ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
31553         RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
31554         ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
31555         RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
31556         ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
31557         RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
31558         ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
31559         RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
31560         IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
31561           WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
31562           STOP
31563         ENDIF
31564         RMSS(19)=SQRT(RMSS(19)**2+DMA2)
31565         RMSS(6)=SQRT(RMSS(6)**2+DL2)
31566         RMSS(7)=SQRT(RMSS(7)**2+DE2)
31567         WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
31568         WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
31569         WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
31570         WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
31571         WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
31572       ENDIF
31573
31574 C...Fix the third generation sfermions.
31575       CALL PYTHRG
31576       XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
31577       IF(XARG.LT.0D0) THEN
31578         WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
31579      &  ' THE SUM RULE. '
31580         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
31581         RETURN
31582       ELSE
31583         PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
31584       ENDIF
31585
31586 C...Fix the neutralino--chargino--gluino sector.
31587       CALL PYINOM
31588
31589 C...Fix the Higgs sector.
31590       CALL PYHGGM(ALFA)
31591
31592 C...Choose the Gunion-Haber convention.
31593       ALFA=-ALFA
31594       RMSS(18)=ALFA
31595
31596 C...Print information on mass parameters.
31597       IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
31598         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31599         WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
31600         WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
31601         WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
31602         WRITE(MSTU(11),*) ' TANB=',RMSS(5)
31603         WRITE(MSTU(11),*) ' MU = ',RMSS(4)
31604         WRITE(MSTU(11),*) ' AT = ',RMSS(16)
31605         WRITE(MSTU(11),*) ' MA = ',RMSS(19)
31606         WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
31607         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31608       ENDIF
31609       IF(IMSS(20).EQ.1) THEN
31610         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31611         WRITE(MSTU(11),*) ' DEBUG MODE '
31612         WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
31613      &  UMIX(2,1),UMIX(2,2)
31614         WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
31615      &  UMIXI(2,1),UMIXI(2,2)
31616         WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
31617      &  VMIX(2,1),VMIX(2,2)
31618         WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
31619      &  VMIXI(2,1),VMIXI(2,2)
31620         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
31621         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
31622         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
31623         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
31624         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
31625         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
31626         WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
31627         WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
31628         WRITE(MSTU(11),*) ' ALFA = ',ALFA
31629         WRITE(MSTU(11),*) ' BETA = ',BETA
31630         WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
31631         WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
31632         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31633       ENDIF
31634
31635 C...Set up the Higgs couplings - needed here since initialization
31636 C...in PYINRE did not yet occur when PYWIDT is called below.
31637       AL=ALFA
31638       BE=BETA
31639       SINA=SIN(AL)
31640       COSA=COS(AL)
31641       COSB=COS(BE)
31642       SINB=TANB*COSB
31643       SBMA=SIN(BE-AL)
31644       SAPB=SIN(AL+BE)
31645       CAPB=COS(AL+BE)
31646       CBMA=COS(BE-AL)
31647       C2A=COS(2D0*AL)
31648       C2B=COSB**2-SINB**2
31649 C...tanb (used for H+)
31650       PARU(141)=TANB
31651
31652 C...Firstly: h
31653 C...Coupling to d-type quarks
31654       PARU(161)=SINA/COSB
31655 C...Coupling to u-type quarks
31656       PARU(162)=-COSA/SINB
31657 C...Coupling to leptons
31658       PARU(163)=PARU(161)
31659 C...Coupling to Z
31660       PARU(164)=SBMA
31661 C...Coupling to W
31662       PARU(165)=PARU(164)
31663
31664 C...Secondly: H
31665 C...Coupling to d-type quarks
31666       PARU(171)=-COSA/COSB
31667 C...Coupling to u-type quarks
31668       PARU(172)=-SINA/SINB
31669 C...Coupling to leptons
31670       PARU(173)=PARU(171)
31671 C...Coupling to Z
31672       PARU(174)=CBMA
31673 C...Coupling to W
31674       PARU(175)=PARU(174)
31675 C...Coupling to h
31676       IF(IMSS(4).EQ.2) THEN
31677         PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
31678       ELSE
31679         HHH(3)=HHH(3)+HHH(4)+HHH(5)
31680         PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
31681      1  HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
31682      2  2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
31683      3  HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
31684       ENDIF
31685 C...Coupling to H+
31686 C...Define later
31687       IF(IMSS(4).EQ.2) THEN
31688         PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
31689       ELSE
31690         PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
31691      1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
31692      2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
31693      3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
31694       ENDIF
31695 C...Coupling to A
31696       IF(IMSS(4).EQ.2) THEN
31697         PARU(177)=COS(2D0*BE)*COS(BE+AL)
31698       ELSE
31699         PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
31700      1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
31701      2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
31702      3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
31703       ENDIF
31704 C...Coupling to H+
31705       IF(IMSS(4).EQ.2) THEN
31706         PARU(178)=PARU(177)
31707       ELSE
31708         PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
31709       ENDIF
31710 C...Thirdly, A
31711 C...Coupling to d-type quarks
31712       PARU(181)=TANB
31713 C...Coupling to u-type quarks
31714       PARU(182)=1D0/PARU(181)
31715 C...Coupling to leptons
31716       PARU(183)=PARU(181)
31717       PARU(184)=0D0
31718       PARU(185)=0D0
31719 C...Coupling to Z h
31720       PARU(186)=COS(BE-AL)
31721 C...Coupling to Z H
31722       PARU(187)=SIN(BE-AL)
31723       PARU(188)=0D0
31724       PARU(189)=0D0
31725       PARU(190)=0D0
31726
31727 C...Finally: H+
31728 C...Coupling to W h
31729       PARU(195)=COS(BE-AL)
31730
31731 C...Tell that all Higgs couplings have been set.
31732       MSTP(4)=1
31733
31734 C...Set R-Violating couplings
31735 C...Set lambda couplings to common value or "natural values".
31736       IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
31737         VIR3=1D0/(126D0)**3
31738         DO 190 IRI=1,3
31739           DO 180 IRJ=1,3
31740             DO 170 IRK=1,3
31741               IF (IRI.NE.IRJ) THEN
31742                 RVLAM(IRI,IRJ,IRK)=RMSS(51)
31743                 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)
31744      &               *SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*PMAS(9+2
31745      &               *IRK,1)*VIR3)
31746               ENDIF
31747               IF (IRI.GT.IRJ) RVLAM(IRI,IRJ,IRK)=-RVLAM(IRI,IRJ,IRK)
31748   170       CONTINUE
31749   180     CONTINUE
31750   190   CONTINUE
31751       ENDIF
31752 C...Set lambda' couplings to common value or "natural values".
31753       IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
31754         VIR3=1D0/(126D0)**3
31755         DO 220 IRI=1,3
31756           DO 210 IRJ=1,3
31757             DO 200 IRK=1,3
31758               RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31759               IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31760      &             *SQRT(PMAS(9+2*IRI,1)*0.5*(PMAS(2*IRJ,1)+PMAS(2*IRJ
31761      &             -1,1))*PMAS(2*IRK-1,1)*VIR3)
31762   200       CONTINUE
31763   210     CONTINUE
31764   220   CONTINUE
31765       ENDIF
31766
31767 C...Second part of routine: set decay modes and branching ratios.
31768
31769 C...Allow chi10 -> gravitino + gamma or not.
31770       KC=PYCOMP(KSUSY1+39)
31771       IF( IMSS(11) .NE. 0 ) THEN
31772         PMAS(KC,1)=RMSS(21)/1000000000D0
31773         PMAS(KC,2)=0.0001D0
31774         IRPRTY=0
31775         WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
31776       ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
31777         IRPRTY=0
31778         WRITE(MSTU(11),*) ' ALLOWING L-VIOLATING DECAYS '
31779       ELSE
31780         PMAS(KC,1)=9999D0
31781         IRPRTY=1
31782       ENDIF
31783
31784 C...Loop over sparticle and Higgs species.
31785       PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
31786 C...Find the LSP or NLSP for a gravitino LSP
31787       ILSP=0
31788       PMLSP=1D20
31789       DO 230 I=1,36
31790         KF=KFSUSY(I)
31791         IF(KF.EQ.1000039) GOTO 230
31792         KC=PYCOMP(KF)
31793         IF(PMAS(KC,1).LT.PMLSP) THEN
31794           ILSP=I
31795           PMLSP=PMAS(KC,1)
31796         ENDIF
31797   230 CONTINUE
31798       DO 300 I=1,36
31799         KF=KFSUSY(I)
31800         KC=PYCOMP(KF)
31801         LKNT=0
31802
31803 C...Sfermion decays.
31804         IF(I.LE.24) THEN
31805 C...First check to see if sneutrino is lighter than chi10.
31806           IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
31807      &    PMAS(KC,1).LT.PMCHI1) THEN
31808           ELSE
31809             CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
31810           ENDIF
31811
31812 C...Gluino decays.
31813         ELSEIF(I.EQ.25) THEN
31814           CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
31815           IF(I.EQ.ILSP) LKNT=0
31816
31817 C...Neutralino decays.
31818         ELSEIF(I.GE.26.AND.I.LE.29) THEN
31819           CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
31820 C...chi10 stable or chi10 -> gravitino + gamma.
31821           IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
31822             PMAS(KC,2)=1D-6
31823             MDCY(KC,1)=0
31824             MWID(KC)=0
31825           ENDIF
31826
31827 C...Chargino decays.
31828         ELSEIF(I.GE.30.AND.I.LE.31) THEN
31829           CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
31830
31831 C...Gravitino is stable.
31832         ELSEIF(I.EQ.32) THEN
31833           MDCY(KC,1)=0
31834           MWID(KC)=0
31835
31836 C...Higgs decays.
31837         ELSEIF(I.GE.33.AND.I.LE.36) THEN
31838 C...Calculate decays to non-SUSY particles.
31839           CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
31840           LKNT=0
31841           DO 240 I1=0,100
31842             XLAM(I1)=0D0
31843   240     CONTINUE
31844           DO 260 I1=1,MDCY(KC,3)
31845             K1=MDCY(KC,2)+I1-1
31846             IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
31847      &      IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 260
31848             XLAM(I1)=WDTP(I1)
31849             XLAM(0)=XLAM(0)+XLAM(I1)
31850             DO 250 J1=1,3
31851               IDLAM(I1,J1)=KFDP(K1,J1)
31852   250       CONTINUE
31853             LKNT=LKNT+1
31854   260     CONTINUE
31855 C...Add the decays to SUSY particles.
31856           CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
31857         ENDIF
31858 C...Zero the branching ratios for use in loop mode
31859 C...thanks to K. Matchev (FNAL)
31860         DO 270 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
31861           BRAT(IDC)=0D0
31862   270   CONTINUE
31863
31864 C...Set stable particles.
31865         IF(LKNT.EQ.0) THEN
31866           MDCY(KC,1)=0
31867           MWID(KC)=0
31868           PMAS(KC,2)=1D-6
31869           PMAS(KC,3)=1D-5
31870           PMAS(KC,4)=0D0
31871
31872 C...Store branching ratios in the standard tables.
31873         ELSE
31874           IDC=MDCY(KC,2)+MDCY(KC,3)-1
31875           DELM=1D6
31876           DO 290 IL=1,LKNT
31877             IDCSV=IDC
31878   280       IDC=IDC+1
31879             BRAT(IDC)=0D0
31880             IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
31881             IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
31882      &      KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
31883               BRAT(IDC)=XLAM(IL)/XLAM(0)
31884               XMDIF=PMAS(KC,1)
31885               IF(MDME(IDC,1).GE.1) THEN
31886                 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
31887      &          PMAS(PYCOMP(KFDP(IDC,2)),1)
31888                 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
31889      &          PMAS(PYCOMP(KFDP(IDC,3)),1)
31890               ENDIF
31891               IF(I.LE.32) THEN
31892                 IF(XMDIF.GE.0D0) THEN
31893                   DELM=MIN(DELM,XMDIF)
31894                 ELSE
31895                   WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
31896                   WRITE(MSTU(11),*) ' KF = ',KF
31897                   WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
31898                 ENDIF
31899               ENDIF
31900               GOTO 290
31901             ELSEIF(IDC.EQ.IDCSV) THEN
31902               WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
31903      &        'channel not recognized:'
31904               WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
31905               GOTO 290
31906             ELSE
31907               GOTO 280
31908             ENDIF
31909   290     CONTINUE
31910
31911 C...Store width, cutoff and lifetime.
31912           PMAS(KC,2)=XLAM(0)
31913           IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
31914             PMAS(KC,3)=PMAS(KC,2)*10D0
31915           ELSE
31916             PMAS(KC,3)=0.95D0*DELM
31917           ENDIF
31918           IF(PMAS(KC,2).NE.0D0) THEN
31919             PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
31920           ENDIF
31921         ENDIF
31922   300 CONTINUE
31923
31924       RETURN
31925       END
31926
31927 C*********************************************************************
31928
31929 C...PYAPPS
31930 C...Uses approximate analytical formulae to determine the full set of
31931 C...MSSM parameters from SUGRA input.
31932 C...See M. Drees and S.P. Martin, hep-ph/9504124
31933
31934       SUBROUTINE PYAPPS
31935
31936 C...Double precision and integer declarations.
31937       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31938       IMPLICIT INTEGER(I-N)
31939       INTEGER PYK,PYCHGE,PYCOMP
31940 C...Parameter statement to help give large particle numbers.
31941       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31942      &KEXCIT=4000000,KDIMEN=5000000)
31943 C...Commonblocks.
31944       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31945       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31946       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31947       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
31948
31949       IMSS(5)=0
31950       XMT=PMAS(6,1)
31951       XMZ2=PMAS(23,1)**2
31952       XMW2=PMAS(24,1)**2
31953       TANB=RMSS(5)
31954       BETA=ATAN(TANB)
31955       XW=PARU(102)
31956       XMG=RMSS(1)
31957       XMG2=XMG*XMG
31958       XM0=RMSS(8)
31959       XM02=XM0*XM0
31960       AT=-RMSS(16)
31961       RMSS(15)=AT
31962       RMSS(17)=AT
31963       COSB=COS(BETA)
31964       SINB=TANB/SQRT(TANB**2+1D0)
31965       COSB=SINB/TANB
31966
31967       DTERM=XMZ2*COS(2D0*BETA)
31968       XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
31969       XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
31970       RMSS(6)=XMEL
31971       RMSS(7)=XMER
31972       XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
31973       XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
31974       XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
31975       XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
31976       DO 100 I=1,5,2
31977         PMAS(PYCOMP(KSUSY1+I),1)=XMDL
31978         PMAS(PYCOMP(KSUSY2+I),1)=XMDR
31979         PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
31980         PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
31981   100 CONTINUE
31982       XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
31983       IF(XARG.LT.0D0) THEN
31984         WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31985      &  ' FROM THE SUM RULE. '
31986         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
31987         RETURN
31988       ELSE
31989         XARG=SQRT(XARG)
31990       ENDIF
31991       DO 110 I=11,15,2
31992         PMAS(PYCOMP(KSUSY1+I),1)=XMEL
31993         PMAS(PYCOMP(KSUSY2+I),1)=XMER
31994         PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31995         PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
31996   110 CONTINUE
31997 C      XMNU=XARG
31998
31999       RMT=PYRNMT(XMT)
32000       XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
32001      &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
32002       RMB=3D0
32003       XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
32004      &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
32005       XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
32006       ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
32007      &SINB)**2)
32008       RMSS(16)=-ATP
32009 C      XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
32010 C.....
32011       XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
32012      &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
32013 C      XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
32014 C.....
32015       XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
32016       XMU=SIGN(SQRT(XMU2),RMSS(4))
32017       RMSS(4)=XMU
32018       RMSS(19)=SQRT(XMA2)
32019       ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
32020       IF(ARG.GT.0D0) THEN
32021         RMSS(14)=SQRT(ARG)
32022       ELSE
32023         WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
32024         STOP
32025       ENDIF
32026       ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
32027       IF(ARG.GT.0D0) THEN
32028         RMSS(13)=SQRT(ARG)
32029       ELSE
32030         WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
32031         STOP
32032       ENDIF
32033       ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
32034       IF(ARG.GT.0D0) THEN
32035         RMSS(10)=SQRT(ARG)
32036       ELSE
32037         RMSS(10)=-SQRT(-ARG)
32038       ENDIF
32039       ARG=PYRNMQ(2,-2D0*XTOP/3D0)
32040       IF(ARG.GT.0D0) THEN
32041         RMSS(12)=SQRT(ARG)
32042       ELSE
32043         RMSS(12)=-SQRT(-ARG)
32044       ENDIF
32045       ARG=PYRNMQ(3,-2D0*XBOT/3D0)
32046       IF(ARG.GT.0D0) THEN
32047         RMSS(11)=SQRT(ARG)
32048       ELSE
32049         RMSS(11)=-SQRT(-ARG)
32050       ENDIF
32051
32052       RETURN
32053       END
32054
32055 C*********************************************************************
32056
32057 C...PYRNMQ
32058 C...Determines the running mass of quarks.
32059
32060       FUNCTION PYRNMQ(ID,DTERM)
32061
32062 C...Double precision and integer declarations.
32063       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32064       IMPLICIT INTEGER(I-N)
32065       INTEGER PYK,PYCHGE,PYCOMP
32066 C...Commonblock.
32067       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32068       SAVE /PYMSSM/
32069
32070 C...Local variables.
32071       DOUBLE PRECISION PI,R
32072       DOUBLE PRECISION TOL
32073       DOUBLE PRECISION CI(3)
32074       EXTERNAL PYALPS
32075       DOUBLE PRECISION PYALPS
32076       DATA TOL/0.001D0/
32077       DATA PI,R/3.141592654D0,.61803399D0/
32078       DATA CI/0.47D0,0.07D0,0.02D0/
32079
32080       C=1D0-R
32081       CA=CI(ID)
32082       AG=(0.71D0)**2/4D0/PI
32083       AG=RMSS(20)
32084       XM0=RMSS(8)
32085       XMG=RMSS(1)
32086       XM02=XM0*XM0
32087       XMG2=XMG*XMG
32088
32089       AS=PYALPS(XM02+6D0*XMG2)
32090       CG=8D0/9D0*((AS/AG)**2-1D0)
32091       BX=XM02+(CA+CG)*XMG2+DTERM
32092       AX=MIN(50D0**2,0.5D0*BX)
32093       CX=MAX(2000D0**2,2D0*BX)
32094
32095       X0=AX
32096       X3=CX
32097       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32098         X1=BX
32099         X2=BX+C*(CX-BX)
32100       ELSE
32101         X2=BX
32102         X1=BX-C*(BX-AX)
32103       ENDIF
32104       AS1=PYALPS(X1)
32105       CG=8D0/9D0*((AS1/AG)**2-1D0)
32106       F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32107       AS2=PYALPS(X2)
32108       CG=8D0/9D0*((AS2/AG)**2-1D0)
32109       F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32110   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32111         IF(F2.LT.F1) THEN
32112           X0=X1
32113           X1=X2
32114           X2=R*X1+C*X3
32115           F1=F2
32116           AS2=PYALPS(X2)
32117           CG=8D0/9D0*((AS2/AG)**2-1D0)
32118           F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32119         ELSE
32120           X3=X2
32121           X2=X1
32122           X1=R*X2+C*X0
32123           F2=F1
32124           AS1=PYALPS(X1)
32125           CG=8D0/9D0*((AS1/AG)**2-1D0)
32126           F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32127         ENDIF
32128         GOTO 100
32129       ENDIF
32130       IF(F1.LT.F2) THEN
32131         PYRNMQ=X1
32132         XMIN=X1
32133       ELSE
32134         PYRNMQ=X2
32135         XMIN=X2
32136       ENDIF
32137
32138       RETURN
32139       END
32140
32141 C*********************************************************************
32142
32143 C...PYRNMT
32144 C...Determines the running mass of the top quark.
32145
32146       FUNCTION PYRNMT(XMT)
32147
32148 C...Double precision and integer declarations.
32149       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32150       IMPLICIT INTEGER(I-N)
32151       INTEGER PYK,PYCHGE,PYCOMP
32152 C...Commonblock.
32153       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32154       SAVE /PYMSSM/
32155
32156 C...Local variables.
32157       DOUBLE PRECISION XMT
32158       DOUBLE PRECISION PI,R
32159       DOUBLE PRECISION TOL
32160       EXTERNAL PYALPS
32161       DOUBLE PRECISION PYALPS
32162       DATA TOL/0.001D0/
32163       DATA PI,R/3.141592654D0,0.61803399D0/
32164
32165       C=1D0-R
32166
32167       BX=XMT
32168       AX=MIN(50D0,BX*0.5D0)
32169       CX=MAX(300D0,2D0*BX)
32170
32171       X0=AX
32172       X3=CX
32173       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32174         X1=BX
32175         X2=BX+C*(CX-BX)
32176       ELSE
32177         X2=BX
32178         X1=BX-C*(BX-AX)
32179       ENDIF
32180       AS1=PYALPS(X1**2)/PI
32181       F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32182       AS2=PYALPS(X2**2)/PI
32183       F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32184   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32185         IF(F2.LT.F1) THEN
32186           X0=X1
32187           X1=X2
32188           X2=R*X1+C*X3
32189           F1=F2
32190           AS2=PYALPS(X2**2)/PI
32191           F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32192         ELSE
32193           X3=X2
32194           X2=X1
32195           X1=R*X2+C*X0
32196           F2=F1
32197           AS1=PYALPS(X1**2)/PI
32198           F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32199         ENDIF
32200         GOTO 100
32201       ENDIF
32202       IF(F1.LT.F2) THEN
32203         PYRNMT=X1
32204         XMIN=X1
32205       ELSE
32206         PYRNMT=X2
32207         XMIN=X2
32208       ENDIF
32209
32210       RETURN
32211       END
32212
32213 C*********************************************************************
32214
32215 C...PYTHRG
32216 C...Calculates the mass eigenstates of the third generation sfermions.
32217 C...Created:  5-31-96
32218
32219       SUBROUTINE PYTHRG
32220
32221 C...Double precision and integer declarations.
32222       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32223       IMPLICIT INTEGER(I-N)
32224       INTEGER PYK,PYCHGE,PYCOMP
32225 C...Parameter statement to help give large particle numbers.
32226       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32227      &KEXCIT=4000000,KDIMEN=5000000)
32228 C...Commonblocks.
32229       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32230       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32231       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32232       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32233      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32234       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32235
32236 C...Local variables.
32237       DOUBLE PRECISION BETA
32238       DOUBLE PRECISION PYRNMT
32239       DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
32240       DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
32241       DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
32242       DOUBLE PRECISION ATR,AMQR,AMQL
32243       INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
32244       INTEGER IF,I,J,II,JJ,IT,L
32245       LOGICAL DTERM
32246       DATA SMALL/1D-3/
32247       DATA ID1/10,10,13/
32248       DATA ID2/5,6,15/
32249       DATA ID3/15,16,17/
32250       DATA ID4/11,12,14/
32251       DATA DTERM/.TRUE./
32252
32253       XMZ2=PMAS(23,1)**2
32254       XMW2=PMAS(24,1)**2
32255       TANB=RMSS(5)
32256       XMU=-RMSS(4)
32257       BETA=ATAN(TANB)
32258       COS2B=COS(2D0*BETA)
32259
32260 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
32261
32262       IOPT=IMSS(5)
32263       IF(IOPT.EQ.1) THEN
32264         CTT=DCOS(RMSS(27))
32265         CTT2=CTT**2
32266         STT=DSIN(RMSS(27))
32267         STT2=STT**2
32268         XM12=RMSS(10)**2
32269         XM22=RMSS(12)**2
32270         XMQL2=CTT2*XM12+STT2*XM22
32271         XMQR2=STT2*XM12+CTT2*XM22
32272         XMFR=PMAS(6,1)
32273         XMF2=PYRNMT(XMFR)**2
32274         ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32275 c        ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
32276 c        XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32277 c        IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32278 c         STT=-STT
32279 c         ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32280 c        ENDIF
32281         RMSS(16)=ATOP
32282 C......SUBTRACT OUT D-TERM AND FERMION MASS
32283         XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
32284         XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
32285         IF(XMQL2.GE.0D0) THEN
32286           RMSS(10)=SQRT(XMQL2)
32287         ELSE
32288           RMSS(10)=-SQRT(-XMQL2)
32289         ENDIF
32290         IF(XMQR2.GE.0D0) THEN
32291           RMSS(12)=SQRT(XMQR2)
32292         ELSE
32293           RMSS(12)=-SQRT(-XMQR2)
32294         ENDIF
32295
32296 C SAME FOR BOTTOM SQUARK
32297         CTT=DCOS(RMSS(26))
32298         CTT2=CTT**2
32299         STT=DSIN(RMSS(26))
32300         STT2=STT**2
32301         XMF=3D00
32302         XMF2=XMF**2
32303         XM12=RMSS(11)**2
32304         XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
32305
32306         IF(ABS(CTT).GE..9999D0) THEN
32307           ABOT=-XMU*TANB
32308           XMQR2=RMSS(11)**2
32309         ELSEIF(ABS(CTT).LE.1D-4) THEN
32310           ABOT=-XMU*TANB
32311           XMQR2=RMSS(11)**2
32312         ELSE
32313           XM22=(XMQL2-CTT2*XM12)/STT2
32314           XMQR2=STT2*XM12+CTT2*XM22
32315           ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32316         ENDIF
32317 c        ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
32318 c        XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32319 c        IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32320 c          STT=-STT
32321 c          ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32322 c        ENDIF
32323         RMSS(15)=ABOT
32324 C......SUBTRACT OUT D-TERM AND FERMION MASS
32325         XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
32326         IF(XMQR2.GE.0D0) THEN
32327           RMSS(11)=SQRT(XMQR2)
32328         ELSE
32329           RMSS(11)=-SQRT(-XMQR2)
32330         ENDIF
32331 C SAME FOR TAU SLEPTON
32332         CTT=DCOS(RMSS(28))
32333         CTT2=CTT**2
32334         STT=DSIN(RMSS(28))
32335         STT2=STT**2
32336         XM12=RMSS(13)**2
32337         XM22=RMSS(14)**2
32338         XMQL2=CTT2*XM12+STT2*XM22
32339         XMQR2=STT2*XM12+CTT2*XM22
32340         XMFR=PMAS(15,1)
32341         XMF2=XMFR**2
32342         ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32343 c        ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
32344 c        XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32345 c        IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32346 c         STT=-STT
32347 c         ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32348 c        ENDIF
32349         RMSS(17)=ATAU
32350 C......SUBTRACT OUT D-TERM AND FERMION MASS
32351         XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
32352         XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
32353         IF(XMQL2.GE.0D0) THEN
32354           RMSS(13)=SQRT(XMQL2)
32355         ELSE
32356           RMSS(13)=-SQRT(-XMQL2)
32357         ENDIF
32358         IF(XMQR2.GE.0D0) THEN
32359           RMSS(14)=SQRT(XMQR2)
32360         ELSE
32361           RMSS(14)=-SQRT(-XMQR2)
32362         ENDIF
32363       ENDIF
32364       DO 170 L=1,3
32365         AMQL=RMSS(ID1(L))
32366         IF(AMQL.LT.0D0) THEN
32367           XMQL2=-AMQL**2
32368         ELSE
32369           XMQL2=AMQL**2
32370         ENDIF
32371         IF=ID2(L)
32372         XMF=PMAS(IF,1)
32373         IF(L.EQ.1) XMF=3D0
32374         IF(L.EQ.2) XMF=PYRNMT(XMF)
32375         XMF2=XMF**2
32376         ATR=RMSS(ID3(L))
32377         AMQR=RMSS(ID4(L))
32378         IF(AMQR.LT.0D0) THEN
32379           XMQR2=-AMQR**2
32380         ELSE
32381           XMQR2=AMQR**2
32382         ENDIF
32383         AM2(1,1)=XMQL2+XMF2
32384         AM2(2,2)=XMQR2+XMF2
32385         IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
32386         IF(DTERM) THEN
32387           IF(L.EQ.1) THEN
32388             AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
32389             AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
32390             AM2(1,2)=XMF*(ATR+XMU*TANB)
32391           ELSEIF(L.EQ.2) THEN
32392             AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
32393             AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
32394             AM2(1,2)=XMF*(ATR+XMU/TANB)
32395           ELSEIF(L.EQ.3) THEN
32396             IF(IMSS(8).EQ.1) THEN
32397               AM2(1,1)=RMSS(6)**2
32398               AM2(2,2)=RMSS(7)**2
32399               AM2(1,2)=0D0
32400               RMSS(13)=RMSS(6)
32401               RMSS(14)=RMSS(7)
32402             ELSE
32403               AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
32404               AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
32405               AM2(1,2)=XMF*(ATR+XMU*TANB)
32406             ENDIF
32407           ENDIF
32408         ENDIF
32409         AM2(2,1)=AM2(1,2)
32410         DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
32411         IF(DETM.LT.0D0) THEN
32412           WRITE(MSTU(11),*) ID2(L),DETM,AM2
32413           CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
32414         ENDIF
32415         SAME=0.5D0*(AM2(1,1)+AM2(2,2))
32416         DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
32417         XMF12=SAME-DIFF
32418         XMF22=SAME+DIFF
32419         IT=0
32420         IF(XMF22-XMF12.GT.0D0) THEN
32421           RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
32422           RT(2,2) = RT(1,1)
32423           RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
32424      &    AM2(1,2)/(XMF22-XMF12))
32425           RT(2,1) = -RT(1,2)
32426         ELSE
32427           RT(1,1) = 1D0
32428           RT(2,2) = RT(1,1)
32429           RT(1,2) = 0D0
32430           RT(2,1) = -RT(1,2)
32431         ENDIF
32432   100   CONTINUE
32433         IT=IT+1
32434
32435         DO 140 I=1,2
32436           DO 130 JJ=1,2
32437             DI(I,JJ)=0D0
32438             DO 120 II=1,2
32439               DO 110 J=1,2
32440                 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
32441   110         CONTINUE
32442   120       CONTINUE
32443   130     CONTINUE
32444   140   CONTINUE
32445
32446         IF(DI(1,1).GT.DI(2,2)) THEN
32447           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
32448           WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
32449           WRITE(MSTU(11),*) AM2
32450           WRITE(MSTU(11),*) DI
32451           WRITE(MSTU(11),*) RT
32452           DI(1,1)=-RT(2,1)
32453           DI(2,2)=RT(1,2)
32454           DI(1,2)=-RT(2,2)
32455           DI(2,1)=RT(1,1)
32456           DO 160 I=1,2
32457             DO 150 J=1,2
32458               RT(I,J)=DI(I,J)
32459   150       CONTINUE
32460   160     CONTINUE
32461           GOTO 100
32462         ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
32463           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32464      &    ' OFF DIAGONAL ELEMENTS '
32465           WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
32466           WRITE(MSTU(11),*) DI
32467           WRITE(MSTU(11),*) ' ROTATION = ',RT
32468 C...STOP
32469         ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
32470           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32471      &    ' NEGATIVE MASSES '
32472           STOP
32473         ENDIF
32474         PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
32475         PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
32476         SFMIX(IF,1)=RT(1,1)
32477         SFMIX(IF,2)=RT(1,2)
32478         SFMIX(IF,3)=RT(2,1)
32479         SFMIX(IF,4)=RT(2,2)
32480   170 CONTINUE
32481
32482       RETURN
32483       END
32484
32485 C*********************************************************************
32486
32487 C...PYINOM
32488 C...Finds the mass eigenstates and mixing matrices for neutralinos
32489 C...and charginos.
32490
32491       SUBROUTINE PYINOM
32492
32493 C...Double precision and integer declarations.
32494       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32495       IMPLICIT INTEGER(I-N)
32496       INTEGER PYCOMP
32497 C...Parameter statement to help give large particle numbers.
32498       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32499      &KEXCIT=4000000,KDIMEN=5000000)
32500 C...Commonblocks.
32501       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32502       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32503       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32504       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32505      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32506       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32507
32508 C...Local variables.
32509       DOUBLE PRECISION XMW,XMZ,XM(4)
32510       DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
32511       DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
32512       DOUBLE PRECISION COSW,SINW
32513       DOUBLE PRECISION XMU
32514       DOUBLE PRECISION TANB,COSB,SINB
32515       DOUBLE PRECISION XM1,XM2,XM3,BETA
32516       DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
32517       DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
32518       DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
32519       DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
32520       DOUBLE PRECISION PYALPS,PYALEM
32521       DOUBLE PRECISION PYRNM3
32522       COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
32523       INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
32524       DATA KFNCHI/1000022,1000023,1000025,1000035/
32525
32526       IOPT=IMSS(2)
32527       IF(IMSS(1).EQ.2) THEN
32528         IOPT=1
32529       ENDIF
32530 C...M1, M2, AND M3 ARE INDEPENDENT
32531       IF(IOPT.EQ.0) THEN
32532         XM1=RMSS(1)
32533         XM2=RMSS(2)
32534         XM3=RMSS(3)
32535       ELSEIF(IOPT.GE.1) THEN
32536         Q2=PMAS(23,1)**2
32537         AEM=PYALEM(Q2)
32538         A2=AEM/PARU(102)
32539         A1=AEM/(1D0-PARU(102))
32540         XM1=RMSS(1)
32541         XM2=RMSS(2)
32542         IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
32543         IF(IOPT.EQ.1) THEN
32544           XM2=XM1*A2/A1*3D0/5D0
32545           RMSS(2)=XM2
32546         ELSEIF(IOPT.EQ.3) THEN
32547           XM1=XM2*5D0/3D0*A1/A2
32548           RMSS(1)=XM1
32549         ENDIF
32550         XM3=PYRNM3(XM2/A2)
32551         RMSS(3)=XM3
32552         IF(XM3.LE.0D0) THEN
32553           WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
32554           STOP
32555         ENDIF
32556       ENDIF
32557
32558 C...GLUINO MASS
32559       IF(IMSS(3).EQ.1) THEN
32560         PMAS(PYCOMP(KSUSY1+21),1)=XM3
32561       ELSE
32562         AQ=0D0
32563         DO 110 I=1,4
32564           DO 100 ILR=1,2
32565             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32566             AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
32567      &      +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
32568   100     CONTINUE
32569   110   CONTINUE
32570
32571         DO 130 I=5,6
32572           DO 120 ILR=1,2
32573             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32574             RM2=PMAS(I,1)**2/XM3**2
32575             ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
32576             IF(ARG.GE.0D0) THEN
32577               X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
32578               AX0=ABS(X0)
32579               X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
32580               AX1=ABS(X1)
32581               IF(X0.EQ.1D0) THEN
32582                 AT=-1D0
32583                 BT=0.25D0
32584               ELSEIF(X0.EQ.0D0) THEN
32585                 AT=0D0
32586                 BT=-0.25D0
32587               ELSE
32588                 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
32589      &          0.5D0*X0**2*LOG(AX0)
32590                 BT=(-1D0-2D0*X0)/4D0
32591               ENDIF
32592               IF(X1.EQ.1D0) THEN
32593                 AT=-1D0+AT
32594                 BT=0.25D0+BT
32595               ELSEIF(X1.EQ.0D0) THEN
32596                 AT=0D0+AT
32597                 BT=-0.25D0+BT
32598               ELSE
32599                 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
32600      &          X1**2*LOG(AX1)+AT
32601                 BT=(-1D0-2D0*X1)/4D0+BT
32602               ENDIF
32603               AQ=AQ+AT+BT
32604             ELSE
32605               X0=0.5D0*(1D0+RM2-RM1)
32606               Y0=-0.5D0*SQRT(-ARG)
32607               AMGX0=SQRT(X0**2+Y0**2)
32608               AM1X0=SQRT((1D0-X0)**2+Y0**2)
32609               ARGX0=ATAN2(-X0,-Y0)
32610               AR1X0=ATAN2(1D0-X0,Y0)
32611               X1=X0
32612               Y1=-Y0
32613               AMGX1=AMGX0
32614               AM1X1=AM1X0
32615               ARGX1=ATAN2(-X1,-Y1)
32616               AR1X1=ATAN2(1D0-X1,Y1)
32617               AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
32618      &        +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
32619               BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
32620               AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
32621      &        +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
32622               BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
32623               AQ=AQ+AT+BT
32624             ENDIF
32625   120     CONTINUE
32626   130   CONTINUE
32627         PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
32628      &  (15D0+AQ))
32629       ENDIF
32630
32631 C...NEUTRALINO MASSES
32632       DO 150 I=1,4
32633         DO 140 J=1,4
32634           AI(I,J)=0D0
32635   140   CONTINUE
32636   150 CONTINUE
32637       XMZ=PMAS(23,1)
32638       XMW=PMAS(24,1)
32639       XMU=RMSS(4)
32640       SINW=SQRT(PARU(102))
32641       COSW=SQRT(1D0-PARU(102))
32642       TANB=RMSS(5)
32643       BETA=ATAN(TANB)
32644       COSB=COS(BETA)
32645       SINB=TANB*COSB
32646
32647 C... Definitions:
32648 C...    psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
32649 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
32650       AR(1,1) = XM1*COS(RMSS(30))
32651       AI(1,1) = XM1*SIN(RMSS(30))
32652       AR(2,2) = XM2*COS(RMSS(31))
32653       AI(2,2) = XM2*SIN(RMSS(31))
32654       AR(3,3) = 0D0
32655       AR(4,4) = 0D0
32656       AR(1,2) = 0D0
32657       AR(2,1) = 0D0
32658       AR(1,3) = -XMZ*SINW*COSB
32659       AR(3,1) = AR(1,3)
32660       AR(1,4) = XMZ*SINW*SINB
32661       AR(4,1) = AR(1,4)
32662       AR(2,3) = XMZ*COSW*COSB
32663       AR(3,2) = AR(2,3)
32664       AR(2,4) = -XMZ*COSW*SINB
32665       AR(4,2) = AR(2,4)
32666       AR(3,4) = -XMU*COS(RMSS(33))
32667       AI(3,4) = -XMU*SIN(RMSS(33))
32668       AR(4,3) = -XMU*COS(RMSS(33))
32669       AI(4,3) = -XMU*SIN(RMSS(33))
32670 C      CALL PYEIG4(AR,WR,ZR)
32671       CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32672       IF(IERR.NE.0) THEN
32673        WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32674       ENDIF
32675       DO 160 I=1,4
32676         INDEX(I)=I
32677         XM(I)=ABS(WR(I))
32678   160 CONTINUE
32679       DO 180 I=2,4
32680         K=I
32681         DO 170 J=I-1,1,-1
32682           IF(XM(K).LT.XM(J)) THEN
32683             ITMP=INDEX(J)
32684             XTMP=XM(J)
32685             INDEX(J)=INDEX(K)
32686             XM(J)=XM(K)
32687             INDEX(K)=ITMP
32688             XM(K)=XTMP
32689             K=K-1
32690           ELSE
32691             GOTO 180
32692           ENDIF
32693   170   CONTINUE
32694   180 CONTINUE
32695
32696
32697       DO 210 I=1,4
32698         K=INDEX(I)
32699         SMZ(I)=WR(K)
32700         PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
32701         S=0D0
32702         DO 190 J=1,4
32703           S=S+ZR(J,K)**2+ZI(J,K)**2
32704   190   CONTINUE
32705         DO 200 J=1,4
32706           ZMIX(I,J)=ZR(J,K)/SQRT(S)
32707           ZMIXI(I,J)=ZI(J,K)/SQRT(S)
32708           IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
32709           IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
32710   200   CONTINUE
32711   210 CONTINUE
32712
32713 C...CHARGINO MASSES
32714 C.....Find eigenvectors of X X^*
32715       AI(1,1) = 0D0
32716       AI(2,2) = 0D0
32717       AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
32718       AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
32719       AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32720      &XMU*COS(RMSS(33))*SINB)
32721       AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
32722      &XMU*SIN(RMSS(33))*SINB)
32723       AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32724      &XMU*COS(RMSS(33))*SINB)
32725       AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
32726      &XMU*SIN(RMSS(33))*SINB)
32727       CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32728       IF(IERR.NE.0) THEN
32729        WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32730       ENDIF
32731       INDEX(1)=1
32732       INDEX(2)=2
32733       IF(WR(2).LT.WR(1)) THEN
32734         INDEX(1)=2
32735         INDEX(2)=1
32736       ENDIF
32737
32738       DO 240 I=1,2
32739         K=INDEX(I)
32740         SMW(I)=SQRT(WR(K))
32741         S=0D0
32742         DO 220 J=1,2
32743           S=S+ZR(J,K)**2+ZI(J,K)**2
32744   220   CONTINUE
32745         DO 230 J=1,2
32746           UMIX(I,J)=ZR(J,K)/SQRT(S)
32747           UMIXI(I,J)=-ZI(J,K)/SQRT(S)
32748           IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
32749           IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
32750   230   CONTINUE
32751   240 CONTINUE
32752       IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
32753        SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
32754       ENDIF
32755       PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
32756       PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
32757
32758 C.....Find eigenvectors of X^* X
32759       AI(1,1) = 0D0
32760       AI(2,2) = 0D0
32761       AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
32762       AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
32763       AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32764      &XMU*COS(RMSS(33))*COSB)
32765       AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
32766      &XMU*SIN(RMSS(33))*COSB)
32767       AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32768      &XMU*COS(RMSS(33))*COSB)
32769       AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
32770      &XMU*SIN(RMSS(33))*COSB)
32771       CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32772       IF(IERR.NE.0) THEN
32773        WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32774       ENDIF
32775       INDEX(1)=1
32776       INDEX(2)=2
32777       IF(WR(2).LT.WR(1)) THEN
32778         INDEX(1)=2
32779         INDEX(2)=1
32780       ENDIF
32781
32782       DO 270 I=1,2
32783         K=INDEX(I)
32784         S=0D0
32785         DO 250 J=1,2
32786           S=S+ZR(J,K)**2+ZI(J,K)**2
32787   250   CONTINUE
32788         DO 260 J=1,2
32789           VMIX(I,J)=ZR(J,K)/SQRT(S)
32790           VMIXI(I,J)=-ZI(J,K)/SQRT(S)
32791           IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
32792           IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
32793   260   CONTINUE
32794   270 CONTINUE
32795
32796
32797       RETURN
32798       END
32799
32800 C*********************************************************************
32801
32802 C...PYRNM3
32803 C...Calculates the running of M3, the SU(3) gluino mass parameter.
32804
32805       FUNCTION PYRNM3(RGUT)
32806
32807 C...Double precision and integer declarations.
32808       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32809       IMPLICIT INTEGER(I-N)
32810       INTEGER PYK,PYCHGE,PYCOMP
32811
32812 C...Local variables.
32813       DOUBLE PRECISION R
32814       DOUBLE PRECISION TOL
32815       EXTERNAL PYALPS
32816       DOUBLE PRECISION PYALPS
32817       DATA TOL/0.001D0/
32818       DATA R/0.61803399D0/
32819
32820       C=1D0-R
32821
32822       BX=RGUT*PYALPS(RGUT**2)
32823       AX=MIN(50D0,BX*0.5D0)
32824       CX=MAX(2000D0,2D0*BX)
32825
32826       X0=AX
32827       X3=CX
32828       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32829         X1=BX
32830         X2=BX+C*(CX-BX)
32831       ELSE
32832         X2=BX
32833         X1=BX-C*(BX-AX)
32834       ENDIF
32835       AS1=PYALPS(X1**2)
32836       F1=ABS(X1-RGUT*AS1)
32837       AS2=PYALPS(X2**2)
32838       F2=ABS(X2-RGUT*AS2)
32839   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32840         IF(F2.LT.F1) THEN
32841           X0=X1
32842           X1=X2
32843           X2=R*X1+C*X3
32844           F1=F2
32845           AS2=PYALPS(X2**2)
32846           F2=ABS(X2-RGUT*AS2)
32847         ELSE
32848           X3=X2
32849           X2=X1
32850           X1=R*X2+C*X0
32851           F2=F1
32852           AS1=PYALPS(X1**2)
32853           F1=ABS(X1-RGUT*AS1)
32854         ENDIF
32855         GOTO 100
32856       ENDIF
32857       IF(F1.LT.F2) THEN
32858         PYRNM3=X1
32859         XMIN=X1
32860       ELSE
32861         PYRNM3=X2
32862         XMIN=X2
32863       ENDIF
32864
32865       RETURN
32866       END
32867
32868 C*********************************************************************
32869
32870 C...PYEIG4
32871 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
32872 C...Specific application: mixing in neutralino sector.
32873
32874       SUBROUTINE PYEIG4(A,W,Z)
32875
32876 C...Double precision and integer declarations.
32877       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32878       IMPLICIT INTEGER(I-N)
32879       INTEGER PYK,PYCHGE,PYCOMP
32880
32881 C...Arrays: in call and local.
32882       DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
32883
32884 C...Coefficients of fourth-degree equation from matrix.
32885 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
32886       B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
32887       B2=0D0
32888       DO 110 I=1,3
32889         DO 100 J=I+1,4
32890           B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
32891   100   CONTINUE
32892   110 CONTINUE
32893       B1=0D0
32894       B0=0D0
32895       DO 120 I=1,4
32896         I1=MOD(I,4)+1
32897         I2=MOD(I+1,4)+1
32898         I3=MOD(I+2,4)+1
32899         B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
32900      &  A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
32901      &  A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
32902         B0=B0+(-1D0)**(I+1)*A(1,I)*(
32903      &  A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
32904      &  A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
32905      &  A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
32906   120 CONTINUE
32907
32908 C...Coefficients of third-degree equation needed for
32909 C...separation into two second-degree equations.
32910 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
32911       C2=-B2
32912       C1=B1*B3-4D0*B0
32913       C0=-B1**2-B0*B3**2+4D0*B0*B2
32914       CQ=C1/3D0-C2**2/9D0
32915       CR=C1*C2/6D0-C0/2D0-C2**3/27D0
32916       CQR=CQ**3+CR**2
32917
32918 C...Cases with one or three real roots.
32919       IF(CQR.GE.0D0) THEN
32920         S1=(CR+SQRT(CQR))**(1D0/3D0)
32921         S2=(CR-SQRT(CQR))**(1D0/3D0)
32922         U=S1+S2-C2/3D0
32923       ELSE
32924         SABS=SQRT(-CQ)
32925         THE=ACOS(CR/SABS**3)/3D0
32926         SRE=SABS*COS(THE)
32927         U=2D0*SRE-C2/3D0
32928       ENDIF
32929
32930 C...Find and solve two second-degree equations.
32931       P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
32932       P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
32933       Q1=U/2D0+SQRT(U**2/4D0-B0)
32934       Q2=U/2D0-SQRT(U**2/4D0-B0)
32935       IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
32936         QSAV=Q1
32937         Q1=Q2
32938         Q2=QSAV
32939       ENDIF
32940       X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
32941       X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
32942       X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
32943       X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
32944
32945 C...Order eigenvalues in asceding mass.
32946       W(1)=X(1)
32947       DO 150 I1=2,4
32948         DO 130 I2=I1-1,1,-1
32949           IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
32950           W(I2+1)=W(I2)
32951   130   CONTINUE
32952   140   W(I2+1)=X(I1)
32953   150 CONTINUE
32954
32955 C...Find equation system for eigenvectors.
32956       DO 250 I=1,4
32957         DO 170 J1=1,4
32958           D(J1,J1)=A(J1,J1)-W(I)
32959           DO 160 J2=J1+1,4
32960             D(J1,J2)=A(J1,J2)
32961             D(J2,J1)=A(J2,J1)
32962   160     CONTINUE
32963   170   CONTINUE
32964
32965 C...Find largest element in matrix.
32966         DAMAX=0D0
32967         DO 190 J1=1,4
32968           DO 180 J2=1,4
32969             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
32970             JA=J1
32971             JB=J2
32972             DAMAX=ABS(D(J1,J2))
32973   180     CONTINUE
32974   190   CONTINUE
32975
32976 C...Subtract others by multiple of row selected above.
32977         DAMAX=0D0
32978         DO 210 J3=JA+1,JA+3
32979           J1=J3-4*((J3-1)/4)
32980           RL=D(J1,JB)/D(JA,JB)
32981           DO 200 J2=1,4
32982             D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
32983             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
32984             JC=J1
32985             JD=J2
32986             DAMAX=ABS(D(J1,J2))
32987   200     CONTINUE
32988   210   CONTINUE
32989
32990 C...Do one more subtraction of a row.
32991         DAMAX=0D0
32992         DO 230 J3=JC+1,JC+3
32993           J1=J3-4*((J3-1)/4)
32994           IF(J1.EQ.JA) GOTO 230
32995           RL=D(J1,JD)/D(JC,JD)
32996           DO 220 J2=1,4
32997             IF(J2.EQ.JB) GOTO 220
32998             D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
32999             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
33000             JE=J1
33001             DAMAX=ABS(D(J1,J2))
33002   220     CONTINUE
33003   230   CONTINUE
33004
33005 C...Construct unnormalized eigenvector.
33006         JF1=JD+1-4*(JD/4)
33007         JF2=JD+2-4*((JD+1)/4)
33008         IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
33009         IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
33010         E(JF1)=-D(JE,JF2)
33011         E(JF2)=D(JE,JF1)
33012         E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
33013         E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
33014      &  D(JA,JB)
33015
33016 C...Normalize and fill in final array.
33017         EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
33018         SGN=(-1D0)**INT(PYR(0)+0.5D0)
33019         DO 240 J=1,4
33020           Z(I,J)=SGN*E(J)/EA
33021   240   CONTINUE
33022   250 CONTINUE
33023
33024       RETURN
33025       END
33026
33027 C*********************************************************************
33028
33029 C...PYHGGM
33030 C...Determines the Higgs boson mass spectrum using several inputs.
33031
33032       SUBROUTINE PYHGGM(ALPHA)
33033
33034 C...Double precision and integer declarations.
33035       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33036       IMPLICIT INTEGER(I-N)
33037       INTEGER PYK,PYCHGE,PYCOMP
33038 C...Parameter statement to help give large particle numbers.
33039       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33040      &KEXCIT=4000000,KDIMEN=5000000)
33041 C...Commonblocks.
33042       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33043       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33044       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33045       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33046       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
33047
33048 C...Local variables.
33049       DOUBLE PRECISION AT,AB,XMU,TANB
33050       DOUBLE PRECISION ALPHA
33051       INTEGER IHOPT
33052       DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
33053       DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
33054       DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
33055       DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
33056
33057       IHOPT=IMSS(4)
33058       IF(IHOPT.EQ.2) THEN
33059         ALPHA=RMSS(18)
33060         RETURN
33061       ENDIF
33062       AT=RMSS(16)
33063       AB=RMSS(15)
33064       DMGL=RMSS(3)
33065       XMU=RMSS(4)
33066       TANB=RMSS(5)
33067
33068       DMA=RMSS(19)
33069       DTANB=TANB
33070       DMQ=RMSS(10)
33071       DMUR=RMSS(12)
33072       DMDR=RMSS(11)
33073       DMTOP=PMAS(6,1)
33074       DMC=PMAS(PYCOMP(KSUSY1+37),1)
33075       DAU=AT
33076       DAD=AB
33077       DMU=XMU
33078       RMSS(40)=0D0
33079       RMSS(41)=0D0
33080
33081       IF(IHOPT.EQ.0) THEN
33082         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33083      &  DMHCH,DSA,DCA,DTANBA)
33084       ELSEIF(IHOPT.EQ.1) THEN
33085         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33086      &  DMHCH,DSA,DCA,DTANBA)
33087         CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
33088      &  DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
33089      &  DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
33090         RMSS(40)=DDT
33091         RMSS(41)=DDB
33092         DMH=DMHP
33093         DHM=DHMP
33094         DMA=DAMP
33095         IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
33096          WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
33097          WRITE(MSTU(11),*) ' STOP1 MASSES = ',
33098      & PMAS(PYCOMP(1000006),1),DSTOP2
33099         ENDIF
33100         IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
33101          WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
33102          WRITE(MSTU(11),*) ' STOP2 MASSES = ',
33103      & PMAS(PYCOMP(2000006),1),DSTOP1
33104         ENDIF
33105         IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
33106          WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
33107          WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
33108      & PMAS(PYCOMP(1000005),1),DSBOT2
33109         ENDIF
33110         IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
33111          WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
33112          WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
33113      & PMAS(PYCOMP(2000005),1),DSBOT1
33114         ENDIF
33115
33116       ENDIF
33117
33118       ALPHA=ACOS(DCA)
33119
33120       PMAS(25,1)=DMH
33121       PMAS(35,1)=DHM
33122       PMAS(36,1)=DMA
33123       PMAS(37,1)=DMHCH
33124
33125       RETURN
33126       END
33127
33128 C*********************************************************************
33129
33130 C...PYSUBH
33131 C...This routine computes the renormalization group improved
33132 C...values of Higgs masses and couplings in the MSSM.
33133
33134 C...Program based on the work by M. Carena, J.R. Espinosa,
33135 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
33136
33137 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
33138 C...All masses in GeV units. MA is the CP-odd Higgs mass,
33139 C...MTOP is the physical top mass, MQ and MUR are the soft
33140 C...supersymmetry breaking mass parameters of left handed
33141 C...and right handed stops respectively, AU and AD are the
33142 C...stop and sbottom trilinear soft breaking terms,
33143 C...respectively,  and MU is the supersymmetric
33144 C...Higgs mass parameter. We use the  conventions from
33145 C...the physics report of Haber and Kane: left right
33146 C...stop mixing term proportional to (AU - MU/TANB)
33147 C...We use as input TANB defined at the scale MTOP
33148
33149 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
33150 C...where MH and HM are the lightest and heaviest CP-even
33151 C...Higgs masses, MHCH is the charged Higgs mass and
33152 C...ALPHA is the Higgs mixing angle
33153 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
33154
33155 C...Range of validity:
33156 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
33157 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
33158 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
33159 C...are the sbottom  mass eigenvalues, respectively. This
33160 C...range automatically excludes the existence of tachyons.
33161 C...For the charged Higgs mass computation, the method is
33162 C...valid if
33163 C...2 * |MB * AD* TANB|  < M_SUSY**2,  2 * |MTOP * AU| < M_SUSY**2
33164 C...2 * |MB * MU * TANB| < M_SUSY**2,  2 * |MTOP * MU| < M_SUSY**2
33165 C...where M_SUSY**2 is the average of the squared stop mass
33166 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
33167 C...masses have been assumed to be of order of the stop ones
33168 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
33169
33170       SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
33171      &XMHCH,SA,CA,TANBA)
33172
33173 C...Double precision and integer declarations.
33174       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33175       IMPLICIT INTEGER(I-N)
33176       INTEGER PYK,PYCHGE,PYCOMP
33177 C...Parameter statement to help give large particle numbers.
33178       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33179      &KEXCIT=4000000,KDIMEN=5000000)
33180 C...Commonblocks.
33181       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33182       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33183       COMMON/PYHTRI/HHH(7)
33184       SAVE /PYDAT1/,/PYDAT2/
33185
33186 C...Local variables.
33187       DOUBLE PRECISION PYALEM,PYALPS
33188       DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
33189       DOUBLE PRECISION XMHCH,SA,CA
33190       DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
33191       DOUBLE PRECISION Q02
33192       DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
33193       DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
33194       DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
33195       DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
33196       DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
33197       DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
33198       DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
33199       DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
33200
33201       XMZ = PMAS(23,1)
33202       Q02=XMZ**2
33203       AEM=PYALEM(Q02)
33204       ALP1=AEM/(1D0-PARU(102))
33205       ALP2=AEM/PARU(102)
33206       ALPH3Z=PYALPS(Q02)
33207
33208       ALP1 = 0.0101D0
33209       ALP2 = 0.0337D0
33210       ALPH3Z = 0.12D0
33211
33212       V = 174.1D0
33213       PI = PARU(1)
33214       TANBA = TANB
33215       TANBT = TANB
33216
33217 C...MBOTTOM(MTOP) = 3. GEV
33218       XMB = 3D0
33219       ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
33220      &LOG(XMTOP**2/XMZ**2))
33221
33222 C...RMTOP= RUNNING TOP QUARK MASS
33223       RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
33224       XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
33225       T = LOG(XMS**2/XMTOP**2)
33226       SINB = TANB/((1D0 + TANB**2)**0.5D0)
33227       COSB = SINB/TANB
33228 C...IF(MA.LE.XMTOP) TANBA = TANBT
33229       IF(XMA.GT.XMTOP)
33230      &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
33231      &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
33232      &LOG(XMA**2/XMTOP**2))
33233
33234       SINBT = TANBT/SQRT(1D0 + TANBT**2)
33235       COSBT = 1D0/SQRT(1D0 + TANBT**2)
33236 C      COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
33237       G1 = SQRT(ALP1*4D0*PI)
33238       G2 = SQRT(ALP2*4D0*PI)
33239       G3 = SQRT(ALP3*4D0*PI)
33240       HU = RMTOP/V/SINBT
33241       HD =  XMB/V/COSBT
33242       HU2=HU*HU
33243       HD2=HD*HD
33244       HU4=HU2*HU2
33245       HD4=HD2*HD2
33246       AU2=AU**2
33247       AD2=AD**2
33248       XMS2=XMS**2
33249       XMS3=XMS**3
33250       XMS4=XMS2*XMS2
33251       XMU2=XMU*XMU
33252       PI2=PI*PI
33253
33254       XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
33255       XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
33256       AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
33257      &+ 3D0*(AU + AD)**2/XMS2)/6D0
33258       XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
33259      &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
33260      &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
33261      &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
33262      &-  16D0*G3**2) *T/16D0/PI2)
33263       XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
33264      &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
33265      &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
33266      &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
33267      &-  16D0*G3**2) *T/16D0/PI2)
33268       XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33269      &(HU2 + HD2)*T/16D0/PI2)
33270      &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33271      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33272      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33273      &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
33274      &-  16D0*G3**2) *T/16D0/PI2)
33275      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33276      &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
33277      &-  16D0*G3**2) *T/16D0/PI2)
33278       XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
33279      &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33280      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33281      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33282      &XMS4)*
33283      &(1+ (6D0*HU2 -2D0* HD2
33284      &-  16D0*G3**2) *T/16D0/PI2)
33285      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33286      &XMS4)*
33287      &(1+ (6D0*HD2 -2D0* HU2/2D0
33288      &-  16D0*G3**2) *T/16D0/PI2)
33289       XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
33290      &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
33291      &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
33292      &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
33293       XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
33294      &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33295      &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
33296      &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33297       XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
33298      &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33299      &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
33300      &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33301       HHH(1)=XLAM1
33302       HHH(2)=XLAM2
33303       HHH(3)=XLAM3
33304       HHH(4)=XLAM4
33305       HHH(5)=XLAM5
33306       HHH(6)=XLAM6
33307       HHH(7)=XLAM7
33308       TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
33309      &2D0* XLAM6*SINBT*COSBT
33310      &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
33311      &+ XLAM5*COSBT**2)
33312       DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
33313      &XLAM6*COSBT**2
33314      &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
33315      &2D0* XLAM6* COSBT*SINBT
33316      &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33317      &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
33318      &((XLAM1* COSBT**2 +2D0*
33319      &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
33320      &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
33321      &*SINBT**2
33322      &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
33323      &+ XLAM4) + XLAM6*COSBT**2
33324      &+ XLAM7* SINBT**2))
33325
33326       XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
33327       XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
33328       XHM = SQRT(XHM2)
33329       XMH = SQRT(XMH2)
33330       XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
33331       XMHCH = SQRT(XMHCH2)
33332
33333       SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33334      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33335      &XLAM6* COSBT*SINBT
33336      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33337      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33338      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
33339      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
33340
33341       COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
33342      &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
33343      &XMA**2*SINBT*COSBT))/2D0**0.5D0/
33344      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
33345      &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33346      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33347      &XLAM6* COSBT*SINBT
33348      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33349      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33350      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
33351
33352       SA = -SINALP
33353       CA = -COSALP
33354
33355   100 CONTINUE
33356
33357       RETURN
33358       END
33359
33360 C*********************************************************************
33361
33362 C...PYPOLE
33363 C...This subroutine computes the CP-even higgs and CP-odd pole
33364 c...Higgs masses and mixing angles.
33365
33366 C...Program based on the work by M. Carena, M. Quiros
33367 C...and C.E.M. Wagner, "Effective potential methods and
33368 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
33369
33370 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
33371 C...AT,AB,MU
33372 C...where MCHI is the largest chargino mass, MA is the running
33373 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
33374 C...expectaion values at the scale MTOP, MQ is the third generation
33375 C...left handed squark mass parameter, MUR is the third generation
33376 C...right handed stop mass parameter, MDR is the third generation
33377 C...right handed sbottom mass parameter, MTOP is the pole top quark
33378 C...mass; AT,AB are the soft supersymmetry breaking trilinear
33379 C...couplings of the stop and sbottoms, respectively, and MU is the
33380 C...supersymmetric mass parameter
33381
33382 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
33383 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
33384 C...masses are given, what makes the running of the program
33385 c...much faster and it is quite generally a good approximation
33386 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
33387 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
33388 c...and if IHIGGS=3, then h,H,A polarizations are computed
33389
33390 C...Output: MH and MHP which are the lightest CP-even Higgs running
33391 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
33392 C...Higgs running and pole masses, repectively; SA and CA are the
33393 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
33394 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
33395 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
33396 C...the value of TANB at the CP-odd Higgs mass scale
33397
33398 C...This subroutine makes use of CERN library subroutine
33399 C...integration package, which makes the computation of the
33400 C...pole Higgs masses somewhat faster. We thank P. Janot for this
33401 C...improvement. Those who are not able to call the CERN
33402 C...libraries, please use the subroutine SUBHPOLE2.F, which
33403 C...although somewhat slower, gives identical results
33404
33405       SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
33406      &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
33407
33408 C...Double precision and integer declarations.
33409       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33410       IMPLICIT INTEGER(I-N)
33411
33412 C...Parameters.
33413       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33414       SAVE /PYDAT1/
33415       INTEGER PYK,PYCHGE,PYCOMP
33416
33417 C...Local variables.
33418       DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
33419      &SSBOT2(2),B(2,2),COUPB(2,2),
33420      &HCOUPT(2,2),HCOUPB(2,2),
33421      &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
33422
33423       DELTA(1,1) = 1D0
33424       DELTA(2,2) = 1D0
33425       DELTA(1,2) = 0D0
33426       DELTA(2,1) = 0D0
33427       V = 174.1D0
33428       XMZ=91.18D0
33429       PI=PARU(1)
33430 C      ALP3Z=0.12D0
33431 C      ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
33432
33433 C      RXMT = XMT/(1D0+4*ALP3/3D0/PI)
33434       RXMT = PYRNMT(XMT)
33435       CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
33436      &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
33437
33438       SINB = TANB/(TANB**2+1D0)**0.5D0
33439       COSB = 1D0/(TANB**2+1D0)**0.5D0
33440       COS2B = SINB**2 - COSB**2
33441       SINBPA = SINB*CA + COSB*SA
33442       COSBPA = COSB*CA - SINB*SA
33443       RMBOT = 3D0
33444       XMQ2 = XMQ**2
33445       XMUR2 = XMUR**2
33446       IF(XMUR.LT.0D0) XMUR2=-XMUR2
33447       XMDR2 = XMDR**2
33448       XMST11 = RXMT**2 + XMQ2  - 0.35D0*XMZ**2*COS2B
33449       XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
33450       IF(XMST11.LT.0D0) GOTO 500
33451       IF(XMST22.LT.0D0) GOTO 500
33452       XMSB11 = RMBOT**2 + XMQ2  + 0.42D0*XMZ**2*COS2B
33453       XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
33454       IF(XMSB11.LT.0D0) GOTO 500
33455       IF(XMSB22.LT.0D0) GOTO 500
33456 C      WMST11 = RXMT**2 + XMQ2
33457 C      WMST22 = RXMT**2 + XMUR2
33458       XMST12 = RXMT*(AT - XMU/TANB)
33459       XMSB12 = RMBOT*(AB - XMU*TANB)
33460
33461 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33462 C...STOP EIGENVALUES CALCULATION
33463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33464
33465       STOP12 = 0.5D0*(XMST11+XMST22) +
33466      &0.5D0*((XMST11+XMST22)**2 -
33467      &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
33468       STOP22 = 0.5D0*(XMST11+XMST22) -
33469      &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
33470      &XMST12**2))**0.5D0
33471
33472       IF(STOP22.LT.0D0) GOTO 500
33473       SSTOP2(1) = STOP12
33474       SSTOP2(2) = STOP22
33475       STOP1 = STOP12**0.5D0
33476       STOP2 = STOP22**0.5D0
33477 C      STOP1W = STOP1
33478 C      STOP2W = STOP2
33479
33480       IF(XMST12.EQ.0D0) XST11 = 1D0
33481       IF(XMST12.EQ.0D0) XST12 = 0D0
33482       IF(XMST12.EQ.0D0) XST21 = 0D0
33483       IF(XMST12.EQ.0D0) XST22 = 1D0
33484
33485       IF(XMST12.EQ.0D0) GOTO 110
33486
33487   100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33488       XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33489       XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33490       XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33491
33492   110 T(1,1) = XST11
33493       T(2,2) = XST22
33494       T(1,2) = XST12
33495       T(2,1) = XST21
33496
33497       SBOT12 = 0.5D0*(XMSB11+XMSB22) +
33498      &0.5D0*((XMSB11+XMSB22)**2 -
33499      &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
33500       SBOT22 = 0.5D0*(XMSB11+XMSB22) -
33501      &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
33502      &XMSB12**2))**0.5D0
33503       IF(SBOT22.LT.0D0) GOTO 500
33504       SBOT1 = SBOT12**0.5D0
33505       SBOT2 = SBOT22**0.5D0
33506
33507       SSBOT2(1) = SBOT12
33508       SSBOT2(2) = SBOT22
33509
33510       IF(XMSB12.EQ.0D0) XSB11 = 1D0
33511       IF(XMSB12.EQ.0D0) XSB12 = 0D0
33512       IF(XMSB12.EQ.0D0) XSB21 = 0D0
33513       IF(XMSB12.EQ.0D0) XSB22 = 1D0
33514
33515       IF(XMSB12.EQ.0D0) GOTO 130
33516
33517   120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33518       XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33519       XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33520       XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33521
33522   130 B(1,1) = XSB11
33523       B(2,2) = XSB22
33524       B(1,2) = XSB12
33525       B(2,1) = XSB21
33526
33527
33528       SINT = 0.2320D0
33529       SQR = DSQRT(2D0)
33530       VP = 174.1D0*SQR
33531
33532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33533 C...STARTING OF LIGHT HIGGS
33534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33535
33536       IF(IHIGGS.EQ.0) GOTO 490
33537
33538       DO 150 I = 1,2
33539         DO 140 J = 1,2
33540           COUPT(I,J) =
33541      &    SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
33542      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33543      &    -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
33544      &    -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
33545      &    T(1,J)*T(2,I))
33546   140   CONTINUE
33547   150 CONTINUE
33548
33549
33550       DO 170 I = 1,2
33551         DO 160 J = 1,2
33552           COUPB(I,J) =
33553      &    -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
33554      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33555      &    +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
33556      &    +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
33557      &    B(1,J)*B(2,I))
33558   160   CONTINUE
33559   170 CONTINUE
33560
33561       PRUN = XMH
33562       EPS = 1D-4*PRUN
33563       ITER = 0
33564   180 ITER = ITER + 1
33565       DO 230  I3 = 1,3
33566
33567         PR(I3)=PRUN+(I3-2)*EPS/2
33568         P2=PR(I3)**2
33569         POLT = 0D0
33570         DO 200 I = 1,2
33571           DO 190 J = 1,2
33572             POLT = POLT + COUPT(I,J)**2*3D0*
33573      &      PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33574   190     CONTINUE
33575   200   CONTINUE
33576
33577         POLB = 0D0
33578         DO 220 I = 1,2
33579           DO 210 J = 1,2
33580             POLB = POLB + COUPB(I,J)**2*3D0*
33581      &      PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33582   210     CONTINUE
33583   220   CONTINUE
33584 C        RXMT2 = RXMT**2
33585         XMT2=XMT**2
33586
33587         POLTT =
33588      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
33589      &  CA**2/SINB**2 *
33590      &  (-2D0*XMT**2+0.5D0*P2)*
33591      &  PYFINT(P2,XMT2,XMT2)
33592
33593         POL = POLT + POLB + POLTT
33594         POLAR(I3) = P2 - XMH**2 - POL
33595   230 CONTINUE
33596       DERIV = (POLAR(3)-POLAR(1))/EPS
33597       DRUN = - POLAR(2)/DERIV
33598       PRUN = PRUN + DRUN
33599       P2 = PRUN**2
33600       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
33601       GOTO 180
33602   240 CONTINUE
33603
33604       XMHP = DSQRT(P2)
33605
33606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33607 C...END OF LIGHT HIGGS
33608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33609
33610   250 IF(IHIGGS.EQ.1) GOTO 490
33611
33612 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33613 C... STARTING OF HEAVY HIGGS
33614 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33615
33616       DO 270 I = 1,2
33617         DO 260 J = 1,2
33618           HCOUPT(I,J) =
33619      &    -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
33620      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33621      &    -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
33622      &    -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
33623      &    T(1,J)*T(2,I))
33624   260   CONTINUE
33625   270 CONTINUE
33626
33627       DO 290 I = 1,2
33628         DO 280 J = 1,2
33629           HCOUPB(I,J) =
33630      &    SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
33631      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33632      &    -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
33633      &    -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
33634      &    B(1,J)*B(2,I))
33635           HCOUPB(I,J)=0D0
33636   280   CONTINUE
33637   290 CONTINUE
33638
33639       PRUN = HM
33640       EPS = 1D-4*PRUN
33641       ITER = 0
33642   300 ITER = ITER + 1
33643       DO 350 I3 = 1,3
33644         PR(I3)=PRUN+(I3-2)*EPS/2
33645         HP2=PR(I3)**2
33646
33647         HPOLT = 0D0
33648         DO 320 I = 1,2
33649           DO 310 J = 1,2
33650             HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
33651      &      PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33652   310     CONTINUE
33653   320   CONTINUE
33654
33655         HPOLB = 0D0
33656         DO 340 I = 1,2
33657           DO 330 J = 1,2
33658             HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
33659      &      PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33660   330     CONTINUE
33661   340   CONTINUE
33662
33663 C        RXMT2 = RXMT**2
33664         XMT2  = XMT**2
33665
33666         HPOLTT =
33667      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
33668      &  SA**2/SINB**2 *
33669      &  (-2D0*XMT**2+0.5D0*HP2)*
33670      &  PYFINT(HP2,XMT2,XMT2)
33671
33672         HPOL = HPOLT + HPOLB + HPOLTT
33673         POLAR(I3) =HP2-HM**2-HPOL
33674   350 CONTINUE
33675       DERIV = (POLAR(3)-POLAR(1))/EPS
33676       DRUN = - POLAR(2)/DERIV
33677       PRUN = PRUN + DRUN
33678       HP2 = PRUN**2
33679       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
33680       GOTO 300
33681   360 CONTINUE
33682
33683
33684   370 CONTINUE
33685       HMP = HP2**0.5D0
33686
33687 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33688 C... END OF HEAVY HIGGS
33689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33690
33691       IF(IHIGGS.EQ.2) GOTO 490
33692
33693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33694 C...BEGINNING OF PSEUDOSCALAR HIGGS
33695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33696
33697       DO 390 I = 1,2
33698         DO 380 J = 1,2
33699           ACOUPT(I,J) =
33700      &    -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
33701      &    (T(1,I)*T(2,J) -T(1,J)*T(2,I))
33702   380   CONTINUE
33703   390 CONTINUE
33704       DO 410 I = 1,2
33705         DO 400 J = 1,2
33706           ACOUPB(I,J) =
33707      &    RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
33708      &    (B(1,I)*B(2,J) -B(1,J)*B(2,I))
33709   400   CONTINUE
33710   410 CONTINUE
33711
33712       PRUN = XMA
33713       EPS = 1D-4*PRUN
33714       ITER = 0
33715   420 ITER = ITER + 1
33716       DO 470 I3 = 1,3
33717         PR(I3)=PRUN+(I3-2)*EPS/2
33718         AP2=PR(I3)**2
33719         APOLT = 0D0
33720         DO 440 I = 1,2
33721           DO 430 J = 1,2
33722             APOLT = APOLT + ACOUPT(I,J)**2*3D0*
33723      &      PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33724   430     CONTINUE
33725   440   CONTINUE
33726         APOLB = 0D0
33727         DO 460 I = 1,2
33728           DO 450 J = 1,2
33729             APOLB = APOLB + ACOUPB(I,J)**2*3D0*
33730      &      PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33731   450     CONTINUE
33732   460   CONTINUE
33733 C        RXMT2 = RXMT**2
33734         XMT2=XMT**2
33735         APOLTT =
33736      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
33737      &  COSB**2/SINB**2 *
33738      &  (-0.5D0*AP2)*
33739      &  PYFINT(AP2,XMT2,XMT2)
33740         APOL = APOLT + APOLB + APOLTT
33741         POLAR(I3) = AP2 - XMA**2 -APOL
33742   470 CONTINUE
33743       DERIV = (POLAR(3)-POLAR(1))/EPS
33744       DRUN = - POLAR(2)/DERIV
33745       PRUN = PRUN + DRUN
33746       AP2 = PRUN**2
33747       IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
33748       GOTO 420
33749   480 CONTINUE
33750
33751       AMP = DSQRT(AP2)
33752
33753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33754 C...END OF PSEUDOSCALAR HIGGS
33755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33756
33757       IF(IHIGGS.EQ.3) GOTO 490
33758
33759   490 CONTINUE
33760       RETURN
33761   500 CONTINUE
33762       WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
33763       WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
33764       WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
33765       WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
33766       STOP
33767       END
33768
33769 C*********************************************************************
33770
33771 C...PYRGHM
33772 C...Auxiliary to PYPOLE.
33773
33774       SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
33775      *    MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
33776       IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
33777       DIMENSION VH(2,2),M2(2,2),M2P(2,2)
33778 C...Parameters.
33779       INTEGER MSTU,MSTJ
33780       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33781       SAVE /PYDAT1/
33782
33783       MZ = 91.18D0
33784       PI = PARU(1)
33785       V  = 174.1D0
33786       ALPHA1 = 0.0101D0
33787       ALPHA2 = 0.0337D0
33788       ALPHA3Z = 0.12D0
33789       TANBA = TANB
33790       TANBT = TANB
33791 C     MBOTTOM(MTOP) = 3. GEV
33792       MB = 3D0
33793       ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
33794      *LOG(MTOP**2/MZ**2))
33795 C     RMTOP= RUNNING TOP QUARK MASS
33796       RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
33797       TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
33798       TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
33799       TD = LOG((MD**2 + MTOP**2)/MTOP**2)
33800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33801 C
33802 C    NEW DEFINITION, TGLU.
33803 C
33804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33805       TGLU = LOG(MGLU**2/MTOP**2)
33806       SINB = TANB/DSQRT(1D0 + TANB**2)
33807       COSB = SINB/TANB
33808       IF(MA.GT.MTOP)
33809      *TANBA = TANB*(1D0-3D0/32D0/PI**2*
33810      *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
33811      *LOG(MA**2/MTOP**2))
33812       IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
33813       SINB = TANBT/SQRT(1D0 + TANBT**2)
33814       COSB = 1D0/DSQRT(1D0 + TANBT**2)
33815       G1 = SQRT(ALPHA1*4D0*PI)
33816       G2 = SQRT(ALPHA2*4D0*PI)
33817       G3 = SQRT(ALPHA3*4D0*PI)
33818       HU = RMTOP/V/SINB
33819       HD =  MB/V/COSB
33820       CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
33821      *SBOT1,SBOT2,DELTAMT,DELTAMB)
33822       IF(MQ.GT.MUR) TP = TQ - TU
33823       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
33824       IF(MQ.GT.MUR) TDP = TU
33825       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
33826       IF(MQ.GT.MD) TPD = TQ - TD
33827       IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
33828       IF(MQ.GT.MD) TDPD = TD
33829       IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
33830
33831       IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
33832       IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
33833      * HD**2*(G1**2/3D0+G2**2)*TPD
33834
33835       IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
33836       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
33837      * HU**2*(-G1**2/3D0+G2**2)*TP
33838
33839 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33840 C
33841 C  DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
33842 C  THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
33843 C  AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
33844 C  TWO STOPS.
33845 C
33846 C
33847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33848
33849       IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
33850        IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
33851         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
33852        ENDIF
33853
33854        IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
33855         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33856        ENDIF
33857
33858        IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
33859         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33860        ENDIF
33861
33862        IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
33863         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
33864        ENDIF
33865
33866        IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
33867         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33868        ENDIF
33869
33870        IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
33871         DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33872        ENDIF
33873       ENDIF
33874       DLAMBDA3 = 0D0
33875       DLAMBDA4 = 0D0
33876       IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
33877       IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
33878      *(G2**2-G1**2/3D0)*TPD
33879       IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
33880      *1D0/16D0/PI**2*G1**2*HU**2*TP
33881       IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
33882      * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
33883       IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
33884       IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
33885      *HD**2*TPD
33886       LAMBDA1 = ((G1**2 + G2**2)/4D0)*
33887      * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
33888      *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
33889      *+ (3D0*HD**2/2D0 + HU**2/2D0
33890      *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
33891      *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0  + (3D0*HD**2/2D0 + HU**2/2D0
33892      *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
33893       LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
33894      *(TP + TDP)/8D0/PI**2)
33895      *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
33896      *+ (3D0*HU**2/2D0 + HD**2/2D0
33897      *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
33898      *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
33899      *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
33900       LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33901      *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
33902      *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
33903       LAMBDA4 = (- G2**2/2D0)*(1D0
33904      *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
33905      *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
33906
33907       LAMBDA5 = 0D0
33908       LAMBDA6 = 0D0
33909       LAMBDA7 = 0D0
33910
33911       M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
33912      *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
33913
33914       M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
33915      *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
33916       M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
33917      *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
33918
33919       M2(2,1) = M2(1,2)
33920 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33921 CCC  THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
33922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33923
33924       MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
33925
33926       IF(MCHI.GT.MSSUSY) GOTO 100
33927       IF(MCHI.LT.MTOP) MCHI=MTOP
33928
33929       TCHAR=LOG(MSSUSY**2/MCHI**2)
33930
33931       DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
33932       DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
33933      *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
33934
33935       DELTAM112=2D0*DELTAL12*V**2*COSB**2
33936       DELTAM222=2D0*DELTAL12*V**2*SINB**2
33937       DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
33938
33939       M2(1,1)=M2(1,1)+DELTAM112
33940       M2(2,2)=M2(2,2)+DELTAM222
33941       M2(1,2)=M2(1,2)+DELTAM122
33942       M2(2,1)=M2(2,1)+DELTAM122
33943
33944   100 CONTINUE
33945
33946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33947 CCC  END OF CHARGINOS/NEUTRALINOS
33948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33949
33950       DO 120 I = 1,2
33951         DO 110 J = 1,2
33952           M2P(I,J) = M2(I,J) + VH(I,J)
33953   110   CONTINUE
33954   120 CONTINUE
33955       TRM2P = M2P(1,1) + M2P(2,2)
33956       DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
33957       MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33958       HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33959       HMP = DSQRT(HM2P)
33960       MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
33961       MCH=DSQRT(MCH2)
33962       IF(MH2P.LT.0.) GOTO 130
33963       MHP = SQRT(MH2P)
33964       SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
33965       COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
33966       IF(COS2ALPHA.GT.0.) ALPHA = ASIN(SIN2ALPHA)/2D0
33967       IF(COS2ALPHA.LT.0.) ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
33968       SA = SIN(ALPHA)
33969       CA = COS(ALPHA)
33970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33971 C
33972 C        HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
33973 C        TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
33974 C        HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
33975 C
33976 C
33977 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33978       SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
33979       CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
33980   130 CONTINUE
33981       RETURN
33982       END
33983
33984 C*********************************************************************
33985
33986 C...PYGFXX
33987 C...Auxiliary to PYRGHM.
33988
33989       SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
33990      *  STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
33991       IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
33992       DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
33993 C...Commonblocks.
33994       INTEGER MSTU,MSTJ,KCHG
33995       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33996       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33997       SAVE /PYDAT1/,/PYDAT2/
33998
33999       G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
34000
34001       T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
34002      * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
34003
34004       IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
34005       MQ2 = MQ**2
34006       MUR2 = MUR**2
34007       MD2 = MD**2
34008       TANBA = TANB
34009       SINBA = TANBA/DSQRT(TANBA**2+1D0)
34010       COSBA = SINBA/TANBA
34011
34012       SINB = TANB/DSQRT(TANB**2+1D0)
34013       COSB = SINB/TANB
34014
34015       PI = PARU(1)
34016       MZ = PMAS(23,1)
34017       MW = PMAS(24,1)
34018       SW = 1D0-MW**2/MZ**2
34019       V  = 174.1D0
34020
34021       ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
34022       G2 = DSQRT(0.0336D0*4D0*PI)
34023       G1 = DSQRT(0.0101D0*4D0*PI)
34024
34025       MB = 3D0
34026       IF(MQ.GT.MUR) MST = MQ
34027       IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
34028
34029       MSUSYT = DSQRT(MST**2  + MTOP**2)
34030
34031       IF(MQ.GT.MD) MSB = MQ
34032       IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
34033
34034       MSUSYB = DSQRT(MSB**2 + MB**2)
34035       TT = LOG(MSUSYT**2/MTOP**2)
34036       TB = LOG(MSUSYB**2/MTOP**2)
34037
34038       RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
34039       HT = RMTOP/(V*SINB)
34040       HTST = RMTOP/V
34041       HB = MB/V/COSB
34042       G32 = ALPHA3*4D0*PI
34043       BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
34044       BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
34045       AL2 = 3D0/8D0/PI**2*HT**2
34046 C      BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
34047 C      ALST = 3./8./PI**2*HTST**2
34048       AL1 = 3D0/8D0/PI**2*HB**2
34049
34050       AL(1,1) = AL1
34051       AL(1,2) = (AL2+AL1)/2D0
34052       AL(2,1) = (AL2+AL1)/2D0
34053       AL(2,2) = AL2
34054
34055       IF(MA.GT.MTOP) THEN
34056         VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
34057      *        LOG(MTOP**2/MA**2))
34058         H1I = VI* COSBA
34059         H2I = VI*SINBA
34060         H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
34061         H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
34062         H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
34063         H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
34064       ELSE
34065         VI = V
34066         H1I = VI*COSB
34067         H2I = VI*SINB
34068         H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34069         H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34070         H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34071         H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34072       ENDIF
34073
34074       TANBST = H2T/H1T
34075       SINBT = TANBST/DSQRT(1D0+TANBST**2)
34076
34077       TANBSB = H2B/H1B
34078       SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
34079       COSBB = SINBB/TANBSB
34080
34081       DELTAMT = 0D0
34082       DELTAMB = 0D0
34083
34084       MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34085       MTOP2 = DSQRT(MTOP4)
34086       MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34087      * /(1D0+DELTAMB)**4
34088       MBOT2 = DSQRT(MBOT4)
34089
34090       STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34091      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34092      *  +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34093      *  MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34094       STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34095      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34096      *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34097      *  MQ2 - MUR2)**2*0.25D0
34098      *  + MTOP2*(AT-XMU/TANBST)**2)
34099       IF(STOP22.LT.0.) GOTO 120
34100       SBOT12 = (MQ2 + MD2)*.5D0
34101      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34102      *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34103      *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34104       SBOT22 = (MQ2 + MD2)*.5D0
34105      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34106      *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34107      *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34108       IF(SBOT22.LT.0.) SBOT22 = 10000D0
34109
34110       STOP1 = DSQRT(STOP12)
34111       STOP2 = DSQRT(STOP22)
34112       SBOT1 = DSQRT(SBOT12)
34113       SBOT2 = DSQRT(SBOT22)
34114
34115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34116 C
34117 C     HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
34118 C     ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
34119 C     MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
34120 C     INDUCED CORRECTIONS.
34121 C
34122 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34123
34124       X=SBOT1
34125       Y=SBOT2
34126       Z=XMGL
34127       IF(X.EQ.Y) X = X - 0.00001D0
34128       IF(X.EQ.Z) X = X - 0.00002D0
34129       IF(Y.EQ.Z) Y = Y - 0.00003D0
34130
34131       T1=T(X,Y,Z)
34132       X=STOP1
34133       Y=STOP2
34134       Z=XMU
34135       IF(X.EQ.Y) X = X - 0.00001D0
34136       IF(X.EQ.Z) X = X - 0.00002D0
34137       IF(Y.EQ.Z) Y = Y - 0.00003D0
34138       T2=T(X,Y,Z)
34139       DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
34140      *  + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
34141       X=STOP1
34142       Y=STOP2
34143       Z=XMGL
34144       IF(X.EQ.Y) X = X - 0.00001D0
34145       IF(X.EQ.Z) X = X - 0.00002D0
34146       IF(Y.EQ.Z) Y = Y - 0.00003D0
34147       T3=T(X,Y,Z)
34148       DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
34149
34150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34151 C
34152 C   HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
34153 C   THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
34154 C   POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
34155 C   INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
34156 C   THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
34157 C   TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
34158 C   S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
34159 C   D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
34160 C   QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
34161 C   FORMULATION.  THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
34162 C   CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
34163 C
34164 C
34165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34166
34167       MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34168       MTOP2 = DSQRT(MTOP4)
34169       MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34170      * /(1D0+DELTAMB)**4
34171       MBOT2 = DSQRT(MBOT4)
34172
34173       STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34174      *   +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34175      *   +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34176      *   MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34177       STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34178      *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34179      *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34180      *  MQ2 - MUR2)**2*0.25D0
34181      *  + MTOP2*(AT-XMU/TANBST)**2)
34182
34183       IF(STOP22.LT.0.) GOTO 120
34184       SBOT12 = (MQ2 + MD2)*.5D0
34185      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34186      *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34187      *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34188       SBOT22 = (MQ2 + MD2)*.5D0
34189      *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34190      *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34191      *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34192       IF(SBOT22.LT.0.) GOTO 120
34193
34194
34195       STOP1 = DSQRT(STOP12)
34196       STOP2 = DSQRT(STOP22)
34197       SBOT1 = DSQRT(SBOT12)
34198       SBOT2 = DSQRT(SBOT22)
34199
34200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34201 CCC   D-TERMS
34202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34203       STW=SW
34204
34205       F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
34206      *         LOG(STOP1/STOP2)
34207      *        +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
34208      *        + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
34209
34210       F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
34211      *        LOG(SBOT1/SBOT2)
34212      *        +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
34213      *        - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
34214
34215       F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
34216      *         (-.5D0*LOG(STOP12/STOP22)
34217      *        +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
34218      *         G(STOP12,STOP22))
34219
34220       F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
34221      *         (.5D0*LOG(SBOT12/SBOT22)
34222      *        +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
34223      *        G(SBOT12,SBOT22))
34224
34225       VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
34226      *  (MQ2+MBOT2)/(MD2+MBOT2))
34227      *  + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
34228      *  LOG(SBOT1**2/SBOT2**2)) +
34229      *  MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
34230      *  (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
34231
34232       VH3T(1,1) =
34233      *  MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
34234      * -STOP2**2))**2*G(STOP12,STOP22)
34235
34236       VH3B(1,1)=VH3B(1,1)+
34237      *    MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
34238
34239       VH3T(1,1) = VH3T(1,1) +
34240      *  MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
34241
34242       VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
34243      *  (MQ2+MTOP2)/(MUR2+MTOP2))
34244      *  + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
34245      *  LOG(STOP1**2/STOP2**2)) +
34246      *  MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
34247      *  (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
34248
34249       VH3B(2,2) =
34250      *  MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
34251      * -SBOT2**2))**2*G(SBOT12,SBOT22)
34252
34253       VH3T(2,2)=VH3T(2,2)+
34254      *    MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
34255       VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
34256       VH3T(1,2) = -
34257      *   MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
34258      * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
34259      * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
34260
34261       VH3B(1,2) =
34262      * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
34263      * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
34264      * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
34265
34266
34267       VH3T(1,2)=VH3T(1,2) +
34268      *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
34269
34270       VH3B(1,2)=VH3B(1,2) +
34271      *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
34272
34273       VH3T(2,1) = VH3T(1,2)
34274       VH3B(2,1) = VH3B(1,2)
34275
34276 C      TQ = LOG((MQ2 + MTOP2)/MTOP2)
34277 C      TU = LOG((MUR2+MTOP2)/MTOP2)
34278 C      TQD = LOG((MQ2 + MB**2)/MB**2)
34279 C      TD = LOG((MD2+MB**2)/MB**2)
34280
34281       DO 110 I = 1,2
34282         DO 100 J = 1,2
34283           VH(I,J) =
34284      *   6D0/(8D0*PI**2*(H1T**2+H2T**2))
34285      *   *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
34286      *   6D0/(8D0*PI**2*(H1B**2+H2B**2))
34287      *   *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
34288   100   CONTINUE
34289   110 CONTINUE
34290
34291       GOTO 150
34292   120 DO 140 I =1,2
34293         DO 130 J = 1,2
34294           VH(I,J) = -1D15
34295   130   CONTINUE
34296   140 CONTINUE
34297
34298
34299   150 RETURN
34300       END
34301
34302
34303
34304
34305
34306 C*********************************************************************
34307
34308 C...PYFINT
34309 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
34310
34311       FUNCTION PYFINT(A,B,C)
34312
34313 C...Double precision and integer declarations.
34314       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34315       IMPLICIT INTEGER(I-N)
34316       INTEGER PYK,PYCHGE,PYCOMP
34317 C...Commonblock.
34318       COMMON/PYINTS/XXM(20)
34319       SAVE/PYINTS/
34320
34321 C...Local variables.
34322       EXTERNAL PYFISB
34323       DOUBLE PRECISION PYFISB
34324
34325       XXM(1)=A
34326       XXM(2)=B
34327       XXM(3)=C
34328       XLO=0D0
34329       XHI=1D0
34330       PYFINT  = PYGAUS(PYFISB,XLO,XHI,1D-3)
34331
34332       RETURN
34333       END
34334
34335 C*********************************************************************
34336
34337 C...PYFISB
34338 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
34339
34340       FUNCTION PYFISB(X)
34341
34342 C...Double precision and integer declarations.
34343       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34344       IMPLICIT INTEGER(I-N)
34345       INTEGER PYK,PYCHGE,PYCOMP
34346 C...Commonblock.
34347       COMMON/PYINTS/XXM(20)
34348       SAVE/PYINTS/
34349
34350       PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
34351      &(X*(XXM(2)-XXM(3))+XXM(3)))
34352
34353       RETURN
34354       END
34355
34356 C*********************************************************************
34357
34358 C...PYSFDC
34359 C...Calculates decays of sfermions.
34360
34361       SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
34362
34363 C...Double precision and integer declarations.
34364       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34365       IMPLICIT INTEGER(I-N)
34366       INTEGER PYK,PYCHGE,PYCOMP
34367 C...Parameter statement to help give large particle numbers.
34368       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34369      &KEXCIT=4000000,KDIMEN=5000000)
34370 C...Commonblocks.
34371       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34372       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34373       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34374       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34375      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34376       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34377
34378 C...Local variables.
34379       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
34380       COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
34381       INTEGER KFIN,KCIN
34382       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
34383       DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
34384       DOUBLE PRECISION PYLAMF,XL
34385       DOUBLE PRECISION TANW,XW,AEM,C1,AS
34386       DOUBLE PRECISION AL,AR,BL,BR
34387       DOUBLE PRECISION CH1,CH2,CH3,CH4
34388       DOUBLE PRECISION XMBOT,XMTOP
34389       DOUBLE PRECISION XLAM(0:300)
34390       INTEGER IDLAM(300,3)
34391       INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
34392       DOUBLE PRECISION SR2
34393       DOUBLE PRECISION CBETA,SBETA
34394       DOUBLE PRECISION CW
34395       DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
34396       DOUBLE PRECISION COSA,SINA,TANB
34397       DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
34398       DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
34399       INTEGER IG,KF1,KF2
34400       INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
34401       DATA IGG/23,25,35,36/
34402       DATA PI/3.141592654D0/
34403       DATA SR2/1.4142136D0/
34404       DATA KFNCHI/1000022,1000023,1000025,1000035/
34405       DATA KFCCHI/1000024,1000037/
34406
34407 C...COUNT THE NUMBER OF DECAY MODES
34408       LKNT=0
34409
34410 C...NO NU_R DECAYS
34411       IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
34412      &KFIN.EQ.KSUSY2+16) RETURN
34413
34414       XMW=PMAS(24,1)
34415       XMW2=XMW**2
34416       XMZ=PMAS(23,1)
34417       XW=PARU(102)
34418       TANW = SQRT(XW/(1D0-XW))
34419       CW=SQRT(1D0-XW)
34420
34421       DO 110 I=1,4
34422         DO 100 J=1,4
34423           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
34424   100   CONTINUE
34425   110 CONTINUE
34426       DO 130 I=1,2
34427         DO 120 J=1,2
34428            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
34429            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
34430   120   CONTINUE
34431   130 CONTINUE
34432
34433 C...KCIN
34434       KCIN=PYCOMP(KFIN)
34435 C...ILR is 1 for left and 2 for right.
34436       ILR=KFIN/KSUSY1
34437 C...IFL is matching non-SUSY flavour.
34438       IFL=MOD(KFIN,KSUSY1)
34439 C...IDU is weak isospin, 1 for down and 2 for up.
34440       IDU=2-MOD(IFL,2)
34441
34442       XMI=PMAS(KCIN,1)
34443       XMI2=XMI**2
34444       AEM=PYALEM(XMI2)
34445       AS =PYALPS(XMI2)
34446       C1=AEM/XW
34447       XMI3=XMI**3
34448       EI=KCHG(IFL,1)/3D0
34449
34450       XMBOT=3D0
34451       XMTOP=PYRNMT(PMAS(6,1))
34452       XMBOT=0D0
34453
34454       TANB=RMSS(5)
34455       BETA=ATAN(TANB)
34456       ALFA=RMSS(18)
34457       CBETA=COS(BETA)
34458       SBETA=TANB*CBETA
34459       SINA=SIN(ALFA)
34460       COSA=COS(ALFA)
34461       XMU=-RMSS(4)
34462       ATRIT=RMSS(16)
34463       ATRIB=RMSS(15)
34464       ATRIL=RMSS(17)
34465
34466 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
34467
34468       IF(IMSS(11).EQ.1) THEN
34469         XMP=RMSS(29)
34470         IDG=39+KSUSY1
34471         XMGR=PMAS(PYCOMP(IDG),1)
34472         XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
34473         IF(IFL.EQ.5) THEN
34474           XMF=XMBOT
34475         ELSEIF(IFL.EQ.6) THEN
34476           XMF=XMTOP
34477         ELSE
34478           XMF=PMAS(IFL,1)
34479         ENDIF
34480         IF(XMI.GT.XMGR+XMF) THEN
34481           LKNT=LKNT+1
34482           IDLAM(LKNT,1)=IDG
34483           IDLAM(LKNT,2)=IFL
34484           IDLAM(LKNT,3)=0
34485           XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
34486         ENDIF
34487       ENDIF
34488
34489 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
34490
34491 C...CHARGED DECAYS:
34492       DO 140 IX=1,2
34493 C...DI -> U CHI1-,CHI2-
34494         IF(IDU.EQ.1) THEN
34495           XMFP=PMAS(IFL+1,1)
34496           XMF =PMAS(IFL,1)
34497 C...UI -> D CHI1+,CHI2+
34498         ELSE
34499           XMFP=PMAS(IFL-1,1)
34500           XMF =PMAS(IFL,1)
34501         ENDIF
34502         XMJ=SMW(IX)
34503         AXMJ=ABS(XMJ)
34504         IF(XMI.GE.AXMJ+XMFP) THEN
34505           XMA2=XMJ**2
34506           XMB2=XMFP**2
34507           IF(IDU.EQ.2) THEN
34508             IF(IFL.EQ.6) THEN
34509               XMFP=XMBOT
34510               XMF =XMTOP
34511             ELSEIF(IFL.LT.6) THEN
34512               XMF=0D0
34513               XMFP=0D0
34514             ENDIF
34515             CBL=VMIXC(IX,1)
34516             CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
34517             CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
34518             CAR=0D0
34519           ELSE
34520             IF(IFL.EQ.5) THEN
34521               XMF =XMBOT
34522               XMFP=XMTOP
34523             ELSEIF(IFL.LT.5) THEN
34524               XMF=0D0
34525               XMFP=0D0
34526             ENDIF
34527             CBL=UMIXC(IX,1)
34528             CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
34529             CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
34530             CAR=0D0
34531           ENDIF
34532
34533           CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34534           CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34535           CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34536           CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34537           CAL=CALP
34538           CBL=CBLP
34539           CAR=CARP
34540           CBR=CBRP
34541
34542 C...F1 -> F` CHI
34543           IF(ILR.EQ.1) THEN
34544             CA=CAL
34545             CB=CBL
34546 C...F2 -> F` CHI
34547           ELSE
34548             CA=CAR
34549             CB=CBR
34550           ENDIF
34551           LKNT=LKNT+1
34552           XL=PYLAMF(XMI2,XMA2,XMB2)
34553 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34554           XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34555      &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
34556           IDLAM(LKNT,3)=0
34557           IF(IDU.EQ.1) THEN
34558             IDLAM(LKNT,1)=-KFCCHI(IX)
34559             IDLAM(LKNT,2)=IFL+1
34560           ELSE
34561             IDLAM(LKNT,1)=KFCCHI(IX)
34562             IDLAM(LKNT,2)=IFL-1
34563           ENDIF
34564         ENDIF
34565   140 CONTINUE
34566
34567 C...NEUTRAL DECAYS
34568       DO 150 IX=1,4
34569 C...DI -> D CHI10
34570         XMF=PMAS(IFL,1)
34571         XMJ=SMZ(IX)
34572         AXMJ=ABS(XMJ)
34573         IF(XMI.GE.AXMJ+XMF) THEN
34574           XMA2=XMJ**2
34575           XMB2=XMF**2
34576           IF(IDU.EQ.1) THEN
34577             IF(IFL.EQ.5) THEN
34578               XMF=XMBOT
34579             ELSEIF(IFL.LT.5) THEN
34580               XMF=0D0
34581             ENDIF
34582             CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
34583             CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
34584             CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34585             CBR=CAL
34586           ELSE
34587             IF(IFL.EQ.6) THEN
34588               XMF=XMTOP
34589             ELSEIF(IFL.LT.5) THEN
34590               XMF=0D0
34591             ENDIF
34592             CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
34593             CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
34594             CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34595             CBR=CAL
34596           ENDIF
34597
34598           CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34599           CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34600           CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34601           CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34602           CAL=CALP
34603           CBL=CBLP
34604           CAR=CARP
34605           CBR=CBRP
34606
34607 C...F1 -> F CHI
34608           IF(ILR.EQ.1) THEN
34609             CA=CAL
34610             CB=CBL
34611 C...F2 -> F CHI
34612           ELSE
34613             CA=CAR
34614             CB=CBR
34615           ENDIF
34616           LKNT=LKNT+1
34617           XL=PYLAMF(XMI2,XMA2,XMB2)
34618 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34619           XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34620      &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
34621           IDLAM(LKNT,1)=KFNCHI(IX)
34622           IDLAM(LKNT,2)=IFL
34623           IDLAM(LKNT,3)=0
34624         ENDIF
34625   150 CONTINUE
34626
34627 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
34628 C...IG=23,25,35,36
34629       DO 160 II=1,4
34630         IG=IGG(II)
34631         IF(ILR.EQ.1) GOTO 160
34632         XMB=PMAS(IG,1)
34633         XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
34634         IF(XMI.LT.XMSF1+XMB) GOTO 160
34635         IF(IG.EQ.23) THEN
34636           BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
34637           BR=EI*XW/CW
34638           BLR=0D0
34639         ELSEIF(IG.EQ.25) THEN
34640           IF(IFL.EQ.5) THEN
34641             XMF=XMBOT
34642           ELSEIF(IFL.EQ.6) THEN
34643             XMF=XMTOP
34644           ELSEIF(IFL.LT.5) THEN
34645             XMF=0D0
34646           ELSE
34647             XMF=PMAS(IFL,1)
34648           ENDIF
34649           IF(IDU.EQ.2) THEN
34650             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34651      &      XMF**2/XMW*COSA/SBETA
34652             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34653      &      XMF**2/XMW*COSA/SBETA
34654           ELSE
34655             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34656      &      XMF**2/XMW*(-SINA)/CBETA
34657             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34658      &      XMF**2/XMW*(-SINA)/CBETA
34659           ENDIF
34660           IF(IFL.EQ.5) THEN
34661             AT=ATRIB
34662           ELSEIF(IFL.EQ.6) THEN
34663             AT=ATRIT
34664           ELSEIF(IFL.EQ.15) THEN
34665             AT=ATRIL
34666           ELSE
34667             AT=0D0
34668           ENDIF
34669 C.........need to complexify
34670           IF(IDU.EQ.2) THEN
34671             GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
34672      &      AT*COSA)
34673           ELSE
34674             GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
34675      &      AT*SINA)
34676           ENDIF
34677           BL=GHLL
34678           BR=GHRR
34679           BLR=-GHLR
34680         ELSEIF(IG.EQ.35) THEN
34681           IF(IFL.EQ.5) THEN
34682             XMF=XMBOT
34683           ELSEIF(IFL.EQ.6) THEN
34684             XMF=XMTOP
34685           ELSEIF(IFL.LT.5) THEN
34686             XMF=0D0
34687           ELSE
34688             XMF=PMAS(IFL,1)
34689           ENDIF
34690           IF(IDU.EQ.2) THEN
34691             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34692      &      XMF**2/XMW*SINA/SBETA
34693             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34694      &      XMF**2/XMW*SINA/SBETA
34695           ELSE
34696             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34697      &      XMF**2/XMW*COSA/CBETA
34698             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34699      &      XMF**2/XMW*COSA/CBETA
34700           ENDIF
34701           IF(IFL.EQ.5) THEN
34702             AT=ATRIB
34703           ELSEIF(IFL.EQ.6) THEN
34704             AT=ATRIT
34705           ELSEIF(IFL.EQ.15) THEN
34706             AT=ATRIL
34707           ELSE
34708             AT=0D0
34709           ENDIF
34710 C.........Need to complexify
34711           IF(IDU.EQ.2) THEN
34712             GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
34713      &      AT*SINA)
34714           ELSE
34715             GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
34716      &      AT*COSA)
34717           ENDIF
34718           BL=GHLL
34719           BR=GHRR
34720           BLR=GHLR
34721         ELSEIF(IG.EQ.36) THEN
34722           GHLL=0D0
34723           GHRR=0D0
34724           IF(IFL.EQ.5) THEN
34725             XMF=XMBOT
34726           ELSEIF(IFL.EQ.6) THEN
34727             XMF=XMTOP
34728           ELSEIF(IFL.LT.5) THEN
34729             XMF=0D0
34730           ELSE
34731             XMF=PMAS(IFL,1)
34732           ENDIF
34733           IF(IFL.EQ.5) THEN
34734             AT=ATRIB
34735           ELSEIF(IFL.EQ.6) THEN
34736             AT=ATRIT
34737           ELSEIF(IFL.EQ.15) THEN
34738             AT=ATRIL
34739           ELSE
34740             AT=0D0
34741           ENDIF
34742 C.........Need to complexify
34743           IF(IDU.EQ.2) THEN
34744             GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
34745           ELSE
34746             GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
34747           ENDIF
34748           BL=GHLL
34749           BR=GHRR
34750           BLR=GHLR
34751         ENDIF
34752         AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
34753      &  SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
34754      &  (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
34755         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34756         LKNT=LKNT+1
34757         IF(IG.EQ.23) THEN
34758           XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34759         ELSE
34760           XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
34761         ENDIF
34762         IDLAM(LKNT,3)=0
34763         IDLAM(LKNT,1)=KFIN-KSUSY1
34764         IDLAM(LKNT,2)=IG
34765   160 CONTINUE
34766
34767 C...SF -> SF' + W
34768       XMB=PMAS(24,1)
34769       IF(MOD(IFL,2).EQ.0) THEN
34770         KF1=KSUSY1+IFL-1
34771       ELSE
34772         KF1=KSUSY1+IFL+1
34773       ENDIF
34774       KF2=KF1+KSUSY1
34775       XMSF1=PMAS(PYCOMP(KF1),1)
34776       XMSF2=PMAS(PYCOMP(KF2),1)
34777       IF(XMI.GT.XMB+XMSF1) THEN
34778         IF(MOD(IFL,2).EQ.0) THEN
34779           IF(ILR.EQ.1) THEN
34780             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
34781           ELSE
34782             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
34783           ENDIF
34784         ELSE
34785           IF(ILR.EQ.1) THEN
34786             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
34787           ELSE
34788             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
34789           ENDIF
34790         ENDIF
34791         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34792         LKNT=LKNT+1
34793         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34794         IDLAM(LKNT,3)=0
34795         IDLAM(LKNT,1)=KF1
34796         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34797       ENDIF
34798       IF(XMI.GT.XMB+XMSF2) THEN
34799         IF(MOD(IFL,2).EQ.0) THEN
34800           IF(ILR.EQ.1) THEN
34801             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
34802           ELSE
34803             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
34804           ENDIF
34805         ELSE
34806           IF(ILR.EQ.1) THEN
34807             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
34808           ELSE
34809             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
34810           ENDIF
34811         ENDIF
34812         XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
34813         LKNT=LKNT+1
34814         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34815         IDLAM(LKNT,3)=0
34816         IDLAM(LKNT,1)=KF2
34817         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34818       ENDIF
34819
34820 C...SF -> SF' + HC
34821       XMB=PMAS(37,1)
34822       IF(MOD(IFL,2).EQ.0) THEN
34823         KF1=KSUSY1+IFL-1
34824       ELSE
34825         KF1=KSUSY1+IFL+1
34826       ENDIF
34827       KF2=KF1+KSUSY1
34828       XMSF1=PMAS(PYCOMP(KF1),1)
34829       XMSF2=PMAS(PYCOMP(KF2),1)
34830       IF(XMI.GT.XMB+XMSF1) THEN
34831         XMF=0D0
34832         XMFP=0D0
34833         AT=0D0
34834         AB=0D0
34835         IF(MOD(IFL,2).EQ.0) THEN
34836 C...T1-> B1 HC
34837           IF(ILR.EQ.1) THEN
34838             CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
34839             CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
34840             CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
34841             CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
34842 C...T2-> B1 HC
34843           ELSE
34844             CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
34845             CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
34846             CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
34847             CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
34848           ENDIF
34849           IF(IFL.EQ.6) THEN
34850             XMF=XMTOP
34851             XMFP=XMBOT
34852             AT=ATRIT
34853             AB=ATRIB
34854           ENDIF
34855         ELSE
34856 C...B1 -> T1 HC
34857           IF(ILR.EQ.1) THEN
34858             CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
34859             CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
34860             CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
34861             CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
34862 C...B2-> T1 HC
34863           ELSE
34864             CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
34865             CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
34866             CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
34867             CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
34868           ENDIF
34869           IF(IFL.EQ.5) THEN
34870             XMF=XMTOP
34871             XMFP=XMBOT
34872             AT=ATRIT
34873             AB=ATRIB
34874           ENDIF
34875         ENDIF
34876         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34877         LKNT=LKNT+1
34878 C.......Need to complexify
34879         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34880      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34881      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34882         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34883         IDLAM(LKNT,3)=0
34884         IDLAM(LKNT,1)=KF1
34885         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34886       ENDIF
34887       IF(XMI.GT.XMB+XMSF2) THEN
34888         XMF=0D0
34889         XMFP=0D0
34890         AT=0D0
34891         AB=0D0
34892         IF(MOD(IFL,2).EQ.0) THEN
34893 C...T1-> B2 HC
34894           IF(ILR.EQ.1) THEN
34895             CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
34896             CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
34897             CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
34898             CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
34899 C...T2-> B2 HC
34900           ELSE
34901             CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
34902             CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
34903             CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
34904             CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
34905           ENDIF
34906           IF(IFL.EQ.6) THEN
34907             XMF=XMTOP
34908             XMFP=XMBOT
34909             AT=ATRIT
34910             AB=ATRIB
34911           ENDIF
34912         ELSE
34913 C...B1 -> T2 HC
34914           IF(ILR.EQ.1) THEN
34915             CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
34916             CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
34917             CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
34918             CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
34919 C...B2-> T2 HC
34920           ELSE
34921             CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
34922             CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
34923             CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
34924             CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
34925           ENDIF
34926           IF(IFL.EQ.5) THEN
34927             XMF=XMTOP
34928             XMFP=XMBOT
34929             AT=ATRIT
34930             AB=ATRIB
34931           ENDIF
34932         ENDIF
34933         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34934         LKNT=LKNT+1
34935 C.......Need to complexify
34936         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34937      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34938      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34939         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34940         IDLAM(LKNT,3)=0
34941         IDLAM(LKNT,1)=KF2
34942         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34943       ENDIF
34944
34945 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
34946
34947       IF(IFL.LE.6) THEN
34948         XMFP=0D0
34949         XMF=0D0
34950         IF(IFL.EQ.6) XMF=PMAS(6,1)
34951         IF(IFL.EQ.5) XMF=PMAS(5,1)
34952         XMJ=PMAS(PYCOMP(KSUSY1+21),1)
34953         AXMJ=ABS(XMJ)
34954         IF(XMI.GE.AXMJ+XMF) THEN
34955           AL=-SFMIX(IFL,3)
34956           BL=SFMIX(IFL,1)
34957           AR=-SFMIX(IFL,4)
34958           BR=SFMIX(IFL,2)
34959 C...F1 -> F CHI
34960           IF(ILR.EQ.1) THEN
34961             XCA=AL
34962             XCB=BL
34963 C...F2 -> F CHI
34964           ELSE
34965             XCA=AR
34966             XCB=BR
34967           ENDIF
34968           LKNT=LKNT+1
34969           XMA2=XMJ**2
34970           XMB2=XMF**2
34971           XL=PYLAMF(XMI2,XMA2,XMB2)
34972           XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34973      &    (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
34974           IDLAM(LKNT,1)=KSUSY1+21
34975           IDLAM(LKNT,2)=IFL
34976           IDLAM(LKNT,3)=0
34977         ENDIF
34978       ENDIF
34979
34980 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
34981       IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
34982      &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
34983 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
34984 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
34985 C...M*M = C1**2 * G**2/(16PI**2)
34986 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
34987         LKNT=LKNT+1
34988         XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
34989         XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
34990         IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
34991         IDLAM(LKNT,1)=KSUSY1+22
34992         IDLAM(LKNT,2)=4
34993         IDLAM(LKNT,3)=0
34994       ENDIF
34995
34996 C...R-violating sfermion decays (SKANDS).
34997       CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
34998
34999       IKNT=LKNT
35000       XLAM(0)=0D0
35001       DO 170 I=1,IKNT
35002         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35003         XLAM(0)=XLAM(0)+XLAM(I)
35004   170 CONTINUE
35005       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
35006
35007       RETURN
35008       END
35009
35010 C*********************************************************************
35011
35012 C...PYGLUI
35013 C...Calculates gluino decay modes.
35014
35015       SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
35016
35017 C...Double precision and integer declarations.
35018       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35019       IMPLICIT INTEGER(I-N)
35020       INTEGER PYK,PYCHGE,PYCOMP
35021 C...Parameter statement to help give large particle numbers.
35022       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35023      &KEXCIT=4000000,KDIMEN=5000000)
35024 C...Commonblocks.
35025       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35026       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35027       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35028       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35029      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35030 CC     &SFMIX(16,4),
35031 C      COMMON/PYINTS/XXM(20)
35032       COMPLEX*16 CXC
35033       COMMON/PYINTC/XXC(10),CXC(8)
35034       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35035
35036 C...Local variables
35037       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35038       DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
35039       DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35040       DOUBLE PRECISION PYLAMF,XL
35041       DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
35042       DOUBLE PRECISION CA,CB,AL,AR,BL,BR
35043       DOUBLE PRECISION XLAM(0:300)
35044       INTEGER IDLAM(300,3)
35045       INTEGER LKNT,IX,ILR,I,IKNT,IFL
35046       DOUBLE PRECISION SR2
35047       DOUBLE PRECISION GAM
35048       DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
35049       EXTERNAL PYGAUS,PYXXZ6
35050       DOUBLE PRECISION PYGAUS,PYXXZ6
35051       DOUBLE PRECISION PREC
35052       INTEGER KFNCHI(4),KFCCHI(2)
35053       DATA PI/3.141592654D0/
35054       DATA SR2/1.4142136D0/
35055       DATA PREC/1D-2/
35056       DATA KFNCHI/1000022,1000023,1000025,1000035/
35057       DATA KFCCHI/1000024,1000037/
35058
35059 C...COUNT THE NUMBER OF DECAY MODES
35060       LKNT=0
35061       IF(KFIN.NE.KSUSY1+21) RETURN
35062       KCIN=PYCOMP(KFIN)
35063
35064       XW=PARU(102)
35065       TANW = SQRT(XW/(1D0-XW))
35066
35067       XMI=PMAS(KCIN,1)
35068       AXMI=ABS(XMI)
35069       XMI2=XMI**2
35070       AEM=PYALEM(XMI2)
35071       AS =PYALPS(XMI2)
35072       C1=AEM/XW
35073       XMI3=XMI**3
35074
35075 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
35076
35077       IF(IMSS(11).EQ.1) THEN
35078         XMP=RMSS(29)
35079         IDG=39+KSUSY1
35080         XMGR=PMAS(PYCOMP(IDG),1)
35081         XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35082         IF(AXMI.GT.XMGR) THEN
35083           LKNT=LKNT+1
35084           IDLAM(LKNT,1)=IDG
35085           IDLAM(LKNT,2)=21
35086           IDLAM(LKNT,3)=0
35087           XLAM(LKNT)=XFAC
35088         ENDIF
35089       ENDIF
35090
35091 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
35092
35093       DO 110 IFL=1,6
35094         DO 100 ILR=1,2
35095           XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
35096           AXMJ=ABS(XMJ)
35097           XMF=PMAS(IFL,1)
35098           IF(XMI.GE.AXMJ+XMF) THEN
35099 C...Minus sign difference from gluino-quark-squark feynman rules
35100             AL=SFMIX(IFL,1)
35101             BL=-SFMIX(IFL,3)
35102             AR=SFMIX(IFL,2)
35103             BR=-SFMIX(IFL,4)
35104 C...F1 -> F CHI
35105             IF(ILR.EQ.1) THEN
35106               CA=AL
35107               CB=BL
35108 C...F2 -> F CHI
35109             ELSE
35110               CA=AR
35111               CB=BR
35112             ENDIF
35113             LKNT=LKNT+1
35114             XMA2=XMJ**2
35115             XMB2=XMF**2
35116             XL=PYLAMF(XMI2,XMA2,XMB2)
35117             XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
35118      &      (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
35119             IDLAM(LKNT,1)=ILR*KSUSY1+IFL
35120             IDLAM(LKNT,2)=-IFL
35121             IDLAM(LKNT,3)=0
35122             LKNT=LKNT+1
35123             XLAM(LKNT)=XLAM(LKNT-1)
35124             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35125             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35126             IDLAM(LKNT,3)=0
35127           ENDIF
35128   100   CONTINUE
35129   110 CONTINUE
35130
35131 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
35132 C...GLUINO -> NI Q QBAR
35133       DO 170 IX=1,4
35134         XMJ=SMZ(IX)
35135         AXMJ=ABS(XMJ)
35136         IF(XMI.GE.AXMJ) THEN
35137           DO 120 I=1,4
35138             ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
35139   120     CONTINUE
35140           OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
35141           ORPP=DCONJG(OLPP)
35142           XXC(1)=0D0
35143           XXC(2)=XMJ
35144           XXC(3)=0D0
35145           XXC(4)=XMI
35146           IA=1
35147           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35148           XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35149           XXC(7)=XXC(5)
35150           XXC(8)=XXC(6)
35151           XXC(9)=1D6
35152           XXC(10)=0D0
35153           EI=KCHG(IA,1)/3D0
35154           T3I=SIGN(1D0,EI+1D-6)/2D0
35155           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35156           GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35157           CXC(1)=0D0
35158           CXC(2)=-GLIJ
35159           CXC(3)=0D0
35160           CXC(4)=DCONJG(GLIJ)
35161           CXC(5)=0D0
35162           CXC(6)=GRIJ
35163           CXC(7)=0D0
35164           CXC(8)=-DCONJG(GRIJ)
35165           S12MIN=0D0
35166           S12MAX=(AXMI-AXMJ)**2
35167           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
35168           IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35169             LKNT=LKNT+1
35170             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35171      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35172             IDLAM(LKNT,1)=KFNCHI(IX)
35173             IDLAM(LKNT,2)=1
35174             IDLAM(LKNT,3)=-1
35175           ENDIF
35176           IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35177             LKNT=LKNT+1
35178             XLAM(LKNT)=XLAM(LKNT-1)
35179             IDLAM(LKNT,1)=KFNCHI(IX)
35180             IDLAM(LKNT,2)=3
35181             IDLAM(LKNT,3)=-3
35182           ENDIF
35183   130     CONTINUE
35184           IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35185             CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
35186             LKNT=LKNT+1
35187             XLAM(LKNT)=GAM
35188             IDLAM(LKNT,1)=KFNCHI(IX)
35189             IDLAM(LKNT,2)=5
35190             IDLAM(LKNT,3)=-5
35191           ENDIF
35192 C...U-TYPE QUARKS
35193   140     CONTINUE
35194           IA=2
35195           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35196           XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35197 C        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
35198           XXC(7)=XXC(5)
35199           XXC(8)=XXC(6)
35200           EI=KCHG(IA,1)/3D0
35201           T3I=SIGN(1D0,EI+1D-6)/2D0
35202           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35203           GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35204           CXC(2)=-GLIJ
35205           CXC(4)=DCONJG(GLIJ)
35206           CXC(6)=GRIJ
35207           CXC(8)=-DCONJG(GRIJ)
35208           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
35209           IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35210             LKNT=LKNT+1
35211             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35212      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35213             IDLAM(LKNT,1)=KFNCHI(IX)
35214             IDLAM(LKNT,2)=2
35215             IDLAM(LKNT,3)=-2
35216           ENDIF
35217           IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35218             LKNT=LKNT+1
35219             XLAM(LKNT)=XLAM(LKNT-1)
35220             IDLAM(LKNT,1)=KFNCHI(IX)
35221             IDLAM(LKNT,2)=4
35222             IDLAM(LKNT,3)=-4
35223           ENDIF
35224   150     CONTINUE
35225 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
35226 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
35227           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 160
35228           XMF=PMAS(6,1)
35229           IF(XMI.GE.AXMJ+2D0*XMF) THEN
35230             CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
35231             LKNT=LKNT+1
35232             XLAM(LKNT)=GAM
35233             IDLAM(LKNT,1)=KFNCHI(IX)
35234             IDLAM(LKNT,2)=6
35235             IDLAM(LKNT,3)=-6
35236           ENDIF
35237   160     CONTINUE
35238         ENDIF
35239   170 CONTINUE
35240
35241 C...GLUINO -> CI Q QBAR'
35242       DO 210 IX=1,2
35243         XMJ=SMW(IX)
35244         AXMJ=ABS(XMJ)
35245         IF(XMI.GE.AXMJ) THEN
35246           DO 180 I=1,2
35247             VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
35248             UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
35249   180     CONTINUE
35250           S12MIN=0D0
35251           S12MAX=(AXMI-AXMJ)**2
35252           XXC(1)=0D0
35253           XXC(2)=XMJ
35254           XXC(3)=0D0
35255           XXC(4)=XMI
35256           XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
35257           XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
35258           XXC(9)=1D6
35259           XXC(10)=0D0
35260           OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
35261           ORPP=DCONJG(OLPP)
35262           CXC(1)=DCMPLX(0D0,0D0)
35263           CXC(3)=DCMPLX(0D0,0D0)
35264           CXC(5)=DCMPLX(0D0,0D0)
35265           CXC(7)=DCMPLX(0D0,0D0)
35266           CXC(2)=UMIXC(IX,1)*OLPP/SR2
35267           CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
35268           CXC(6)=DCMPLX(0D0,0D0)
35269           CXC(8)=DCMPLX(0D0,0D0)
35270           IF(XXC(5).LT.AXMI) THEN
35271             XXC(5)=1D6
35272           ELSEIF(XXC(6).LT.AXMI) THEN
35273             XXC(6)=1D6
35274           ENDIF
35275           XXC(7)=XXC(6)
35276           XXC(8)=XXC(5)
35277           IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
35278           IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
35279             LKNT=LKNT+1
35280             XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35281      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
35282             IDLAM(LKNT,1)=KFCCHI(IX)
35283             IDLAM(LKNT,2)=1
35284             IDLAM(LKNT,3)=-2
35285             LKNT=LKNT+1
35286             XLAM(LKNT)=XLAM(LKNT-1)
35287             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35288             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35289             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35290           ENDIF
35291           IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35292             LKNT=LKNT+1
35293             XLAM(LKNT)=XLAM(LKNT-1)
35294             IDLAM(LKNT,1)=KFCCHI(IX)
35295             IDLAM(LKNT,2)=3
35296             IDLAM(LKNT,3)=-4
35297             LKNT=LKNT+1
35298             XLAM(LKNT)=XLAM(LKNT-1)
35299             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35300             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35301             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35302           ENDIF
35303   190     CONTINUE
35304
35305           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 200
35306           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 200
35307           XMF=PMAS(6,1)
35308           XMFP=PMAS(5,1)
35309           IF(XMI.GE.AXMJ+XMF+XMFP) THEN
35310             CALL PYTBBC(IX,80,AXMI,GAM)
35311             LKNT=LKNT+1
35312             XLAM(LKNT)=GAM
35313             IDLAM(LKNT,1)=KFCCHI(IX)
35314             IDLAM(LKNT,2)=5
35315             IDLAM(LKNT,3)=-6
35316             LKNT=LKNT+1
35317             XLAM(LKNT)=XLAM(LKNT-1)
35318             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35319             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35320             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35321           ENDIF
35322   200     CONTINUE
35323         ENDIF
35324   210 CONTINUE
35325
35326       IKNT=LKNT
35327       XLAM(0)=0D0
35328       DO 220 I=1,IKNT
35329         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35330         XLAM(0)=XLAM(0)+XLAM(I)
35331   220 CONTINUE
35332       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
35333
35334       RETURN
35335       END
35336
35337 C*********************************************************************
35338
35339 C...PYTBBN
35340 C...Calculates the three-body decay of gluinos into
35341 C...neutralinos and third generation fermions.
35342
35343       SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
35344
35345 C...Double precision and integer declarations.
35346       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35347       IMPLICIT INTEGER(I-N)
35348       INTEGER PYK,PYCHGE,PYCOMP
35349 C...Parameter statement to help give large particle numbers.
35350       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35351      &KEXCIT=4000000,KDIMEN=5000000)
35352 C...Commonblocks.
35353       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35354       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35355       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35356       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35357      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35358       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35359
35360 C...Local variables.
35361       EXTERNAL PYSIMP,PYLAMF
35362       DOUBLE PRECISION PYSIMP,PYLAMF
35363       INTEGER LIN,NN
35364       DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
35365       DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
35366       DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
35367       DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
35368       DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
35369       DOUBLE PRECISION XLN1,XLN2,B1,B2
35370       DOUBLE PRECISION E,XMGLU,GAM
35371       DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
35372       SAVE HRB,HLB,FLB,FRB
35373       DOUBLE PRECISION ALPHAW,ALPHAS
35374       DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
35375       SAVE HLT,HRT,FLT,FRT
35376       DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
35377       SAVE AMN,AN,ZN
35378       DOUBLE PRECISION AMBOT,SINC,COSC
35379       DOUBLE PRECISION AMTOP,SINA,COSA
35380       DOUBLE PRECISION SINW,COSW,TANW
35381       DOUBLE PRECISION ROT1(4,4)
35382       LOGICAL IFIRST
35383       SAVE IFIRST
35384       DATA IFIRST/.TRUE./
35385
35386       TANB=RMSS(5)
35387       SINB=TANB/SQRT(1D0+TANB**2)
35388       COSB=SINB/TANB
35389       XW=PARU(102)
35390       SINW=SQRT(XW)
35391       COSW=SQRT(1D0-XW)
35392       TANW=SINW/COSW
35393       AMW=PMAS(24,1)
35394       COSC=SFMIX(5,1)
35395       SINC=SFMIX(5,3)
35396       COSA=SFMIX(6,1)
35397       SINA=SFMIX(6,3)
35398       AMBOT=0D0
35399       AMTOP=PYRNMT(PMAS(6,1))
35400       W2=SQRT(2D0)
35401       FAKT1=AMBOT/W2/AMW/COSB
35402       FAKT2=AMTOP/W2/AMW/SINB
35403       IF(IFIRST) THEN
35404         DO 110 II=1,4
35405           AMN(II)=SMZ(II)
35406           DO 100 J=1,4
35407             ROT1(II,J)=0D0
35408             AN(II,J)=0D0
35409   100     CONTINUE
35410   110   CONTINUE
35411         ROT1(1,1)=COSW
35412         ROT1(1,2)=-SINW
35413         ROT1(2,1)=-ROT1(1,2)
35414         ROT1(2,2)=ROT1(1,1)
35415         ROT1(3,3)=COSB
35416         ROT1(3,4)=SINB
35417         ROT1(4,3)=-ROT1(3,4)
35418         ROT1(4,4)=ROT1(3,3)
35419         DO 140 II=1,4
35420           DO 130 J=1,4
35421             DO 120 JJ=1,4
35422               AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
35423   120       CONTINUE
35424   130     CONTINUE
35425   140   CONTINUE
35426         DO 150 J=1,4
35427           ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
35428           ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35429           ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
35430      &    XW)*AN(J,2)/COSW
35431           HRT(J)=ZN(1)*COSA-ZN(3)*SINA
35432           HLT(J)=ZN(1)*COSA+ZN(2)*SINA
35433           FLT(J)=ZN(3)*COSA+ZN(1)*SINA
35434           FRT(J)=ZN(2)*COSA-ZN(1)*SINA
35435 C          FLU(J)=ZN(3)
35436 C          FRU(J)=ZN(2)
35437           ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
35438           ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35439           ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
35440           HRB(J)=ZN(1)*COSC-ZN(3)*SINC
35441           HLB(J)=ZN(1)*COSC+ZN(2)*SINC
35442           FLB(J)=ZN(3)*COSC+ZN(1)*SINC
35443           FRB(J)=ZN(2)*COSC-ZN(1)*SINC
35444 C          FLD(J)=ZN(3)
35445 C          FRD(J)=ZN(2)
35446   150   CONTINUE
35447 C        AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35448 C        AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35449 C        AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35450 C        AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35451         IFIRST=.FALSE.
35452       ENDIF
35453
35454       IF(NINT(3D0*E).EQ.2) THEN
35455         HL=HLT(I)
35456         HR=HRT(I)
35457         FL=FLT(I)
35458         FR=FRT(I)
35459         COSD=SFMIX(6,1)
35460         SIND=SFMIX(6,3)
35461         XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
35462         XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
35463         XM=PMAS(6,1)
35464       ELSE
35465         HL=HLB(I)
35466         HR=HRB(I)
35467         FL=FLB(I)
35468         FR=FRB(I)
35469         COSD=SFMIX(5,1)
35470         SIND=SFMIX(5,3)
35471         XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
35472         XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
35473         XM=PMAS(5,1)
35474       ENDIF
35475       COSD2=COSD*COSD
35476       SIND2=SIND*SIND
35477       COS2D=COSD2-SIND2
35478       SIN2D=SIND*COSD*2D0
35479       HL2=HL*HL
35480       HR2=HR*HR
35481       FL2=FL*FL
35482       FR2=FR*FR
35483       FF=FL*FR
35484       HH=HL*HR
35485       HFL=HL*FL
35486       HFR=HR*FR
35487       HRFL=HR*FL
35488       HLFR=HL*FR
35489       XM2=XM*XM
35490       XMG=XMGLU
35491       XMG2=XMG*XMG
35492       ALPHAW=PYALEM(XMG2)
35493       ALPHAS=PYALPS(XMG2)
35494       XMR=AMN(I)
35495       XMR2=XMR*XMR
35496       XMQ4=XMG*XM2*XMR
35497       XM24=(XMG2+XM2)*(XM2+XMR2)
35498       SMIN=4D0*XM2
35499       SMAX=(XMG-ABS(XMR))**2
35500       XMQA=XMG2+2D0*XM2+XMR2
35501       DO 170 LIN=1,NN-1
35502         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35503         GRS=SBAR-XMQA
35504         W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
35505         W=DSQRT(W)
35506         XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
35507         XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
35508         B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
35509         B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
35510         G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
35511      &  +2D0*(FF*SIND2-HH*COSD2))*W
35512         G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
35513      &  +4D0*HFL*XM*XMR)*XLN1
35514      &  +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
35515      &  +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
35516      &  -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
35517      &  +8D0*HFL*XMQ4*SIN2D)*B1
35518         G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
35519      &  +4D0*HFR*XMR*XM)*XLN2
35520      &  +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
35521      &  +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
35522      &  +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
35523      &  -8D0*HFR*XMQ4*SIN2D)*B2
35524         G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
35525      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
35526      &  -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
35527      &  +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
35528      &  -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
35529         G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
35530      &  (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
35531      &  +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
35532         G(5)=(2D0*(HH*COSD2-FF*SIND2)
35533      &  *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
35534      &  +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
35535      &  +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
35536      &  *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
35537      &  +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
35538      &  +COS2D*XM*(SBAR+XMG2-XMR2))
35539      &  +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
35540      &  *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
35541         G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
35542      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
35543      &  -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
35544      &  -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
35545      &  -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
35546         SUMME(LIN)=0D0
35547         DO 160 J=0,6
35548           SUMME(LIN)=SUMME(LIN)+G(J)
35549   160   CONTINUE
35550   170 CONTINUE
35551       SUMME(0)=0D0
35552       SUMME(NN)=0D0
35553       GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35554      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35555
35556       RETURN
35557       END
35558
35559 C*********************************************************************
35560
35561 C...PYTBBC
35562 C...Calculates the three-body decay of gluinos into
35563 C...charginos and third generation fermions.
35564
35565       SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
35566
35567 C...Double precision and integer declarations.
35568       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35569       IMPLICIT INTEGER(I-N)
35570       INTEGER PYK,PYCHGE,PYCOMP
35571 C...Parameter statement to help give large particle numbers.
35572       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35573      &KEXCIT=4000000,KDIMEN=5000000)
35574 C...Commonblocks.
35575       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35576       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35577       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35578       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35579      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35580       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35581
35582 C...Local variables.
35583       EXTERNAL PYSIMP,PYLAMF
35584       DOUBLE PRECISION PYSIMP,PYLAMF
35585       INTEGER I,NN,LIN
35586       DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
35587       DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
35588       DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
35589       DOUBLE PRECISION SUMME(0:100),A(4,8)
35590       DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
35591       DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
35592       DOUBLE PRECISION XMGLU,GAM
35593       DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
35594      &DDD(2),EEE(2),FFF(2)
35595       SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
35596       DOUBLE PRECISION ALPHAW,ALPHAS
35597       DOUBLE PRECISION AMC(2)
35598       SAVE AMC
35599       DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
35600       DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
35601       SAVE AMSB,AMST
35602       LOGICAL IFIRST
35603       SAVE IFIRST
35604       DATA IFIRST/.TRUE./
35605
35606       TANB=RMSS(5)
35607       SINB=TANB/SQRT(1D0+TANB**2)
35608       COSB=SINB/TANB
35609       XW=PARU(102)
35610       AMW=PMAS(24,1)
35611       COSC=SFMIX(5,1)
35612       SINC=SFMIX(5,3)
35613       COSA=SFMIX(6,1)
35614       SINA=SFMIX(6,3)
35615       AMBOT=0D0
35616       AMTOP=PYRNMT(PMAS(6,1))
35617       W2=SQRT(2D0)
35618       AMW=PMAS(24,1)
35619       FAKT1=AMBOT/W2/AMW/COSB
35620       FAKT2=AMTOP/W2/AMW/SINB
35621       IF(IFIRST) THEN
35622         AMC(1)=SMW(1)
35623         AMC(2)=SMW(2)
35624         DO 100 JJ=1,2
35625           CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
35626           EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
35627           DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
35628           FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
35629           XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
35630           AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
35631           XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
35632           BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
35633   100   CONTINUE
35634         AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35635         AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35636         AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35637         AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35638         IFIRST=.FALSE.
35639       ENDIF
35640       AMTOP=PMAS(6,1)
35641
35642       ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
35643       ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
35644       VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
35645       VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
35646
35647       COS2A=COSA**2-SINA**2
35648       SIN2A=SINA*COSA*2D0
35649       COS2C=COSC**2-SINC**2
35650       SIN2C=SINC*COSC*2D0
35651
35652       XMG=XMGLU
35653       XMT=AMTOP
35654       XMB=0D0
35655       XMR=AMC(I)
35656       XMG2=XMG*XMG
35657       ALPHAW=PYALEM(XMG2)
35658       ALPHAS=PYALPS(XMG2)
35659       XMT2=XMT*XMT
35660       XMB2=XMB*XMB
35661       XMR2=XMR*XMR
35662       XMQ2=XMG2+XMT2+XMB2+XMR2
35663       XMQ4=XMG*XMT*XMB*XMR
35664       XMQ3=XMG2*XMR2+XMT2*XMB2
35665       XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
35666       XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
35667
35668       XMST(1)=AMST(1)*AMST(1)
35669       XMST(2)=AMST(1)*AMST(1)
35670       XMST(3)=AMST(2)*AMST(2)
35671       XMST(4)=AMST(2)*AMST(2)
35672       XMSB(1)=AMSB(1)*AMSB(1)
35673       XMSB(2)=AMSB(2)*AMSB(2)
35674       XMSB(3)=AMSB(1)*AMSB(1)
35675       XMSB(4)=AMSB(2)*AMSB(2)
35676
35677       A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
35678       A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
35679       A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
35680       A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
35681       A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
35682       A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
35683       A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
35684       A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
35685
35686       A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
35687       A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
35688       A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
35689       A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
35690       A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
35691       A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
35692       A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
35693       A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
35694
35695       A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
35696       A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
35697       A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
35698       A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
35699       A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
35700       A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
35701       A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
35702       A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
35703
35704       A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
35705       A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
35706       A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
35707       A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
35708       A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
35709       A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
35710       A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
35711       A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
35712
35713       SMAX=(XMG-ABS(XMR))**2
35714       SMIN=(XMB+XMT)**2+0.1D0
35715
35716       DO 120 LIN=0,NN-1
35717         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35718         AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
35719         GRS=SBAR-XMQ2
35720         W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
35721         W=DSQRT(W)/2D0/SBAR
35722         ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
35723         ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
35724         ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
35725         ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
35726         SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
35727      &  +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
35728      &  +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
35729      &  -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
35730      &  +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
35731      &  +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
35732      &  *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
35733         SUMME(LIN)=SUMME(LIN)-ULR(2)*W
35734      &  +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
35735      &  -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
35736      &  +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
35737      &  +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
35738      &  -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
35739      &  +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
35740      &  *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
35741         SUMME(LIN)=SUMME(LIN)-VLR(1)*W
35742      &  +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
35743      &  +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
35744      &  +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
35745      &  -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
35746      &  +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
35747      &  +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
35748      &  *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
35749         SUMME(LIN)=SUMME(LIN)-VLR(2)*W
35750      &  +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
35751      &  -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
35752      &  +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
35753      &  +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
35754      &  -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
35755      &  +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
35756      &  *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
35757         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
35758      &  *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
35759      &  *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
35760      &  +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
35761         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
35762      &  *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
35763      &  *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
35764      &  +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
35765         DO 110 J=1,4
35766           SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
35767      &    +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
35768      &    +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
35769      &    +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
35770      &    -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
35771      &    -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
35772      &    *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
35773      &    -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
35774      &    +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
35775      &    +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
35776      &    -A(J,6)*(XMG2+XMR2-SBAR)
35777      &    -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
35778      &    *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
35779      &    /(GRS+XMSB(J)+XMST(J))
35780   110   CONTINUE
35781   120 CONTINUE
35782       SUMME(NN)=0D0
35783       GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35784      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35785
35786       RETURN
35787       END
35788
35789 C*********************************************************************
35790
35791 C...PYNJDC
35792 C...Calculates decay widths for the neutralinos (admixtures of
35793 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
35794
35795 C...Input:  KCIN = KF code for particle
35796 C...Output: XLAM = widths
35797 C...        IDLAM = KF codes for decay particles
35798 C...        IKNT = number of decay channels defined
35799 C...AUTHOR: STEPHEN MRENNA
35800 C...Last change:
35801 C...10-15-95:  force decay chi^0_2 -> chi^0_1 + gamma
35802 C...when CHIGAMMA .NE. 0
35803 C...10 FEB 96:  Calculate this decay for small tan(beta)
35804
35805       SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
35806
35807 C...Double precision and integer declarations.
35808       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35809       IMPLICIT INTEGER(I-N)
35810       INTEGER PYK,PYCHGE,PYCOMP
35811 C...Parameter statement to help give large particle numbers.
35812       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35813      &KEXCIT=4000000,KDIMEN=5000000)
35814 C...Commonblocks.
35815       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35816       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35817       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35818 c      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35819 c     &SFMIX(16,4)
35820       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35821      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35822 C      COMMON/PYINTS/XXM(20)
35823       COMPLEX*16 CXC
35824       COMMON/PYINTC/XXC(10),CXC(8)
35825       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35826
35827 C...Local variables.
35828       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35829       COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
35830       INTEGER KFIN
35831       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35832      &XMZ,XMZ2,AXMJ,AXMI
35833       DOUBLE PRECISION S12MIN,S12MAX
35834       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
35835       DOUBLE PRECISION PYLAMF,XL
35836       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
35837       DOUBLE PRECISION PYX2XH,PYX2XG
35838       DOUBLE PRECISION XLAM(0:300)
35839       INTEGER IDLAM(300,3)
35840       INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35841       INTEGER ITH(3),KF1,KF2
35842       INTEGER ITHC
35843       DOUBLE PRECISION DH(3),EH(3)
35844       DOUBLE PRECISION SR2
35845       DOUBLE PRECISION CBETA,SBETA
35846       DOUBLE PRECISION GAMCON,XMT1,XMT2
35847       DOUBLE PRECISION PYALEM,PI,PYALPS
35848       DOUBLE PRECISION RAT1,RAT2
35849       DOUBLE PRECISION T3T,FCOL
35850       DOUBLE PRECISION ALFA,BETA,TANB
35851       DOUBLE PRECISION PYXXGA
35852       EXTERNAL PYGAUS,PYXXZ6
35853       DOUBLE PRECISION PYGAUS,PYXXZ6
35854       DOUBLE PRECISION PREC
35855       INTEGER KFNCHI(4),KFCCHI(2)
35856       DATA ITH/25,35,36/
35857       DATA ITHC/37/
35858       DATA PREC/1D-2/
35859       DATA PI/3.141592654D0/
35860       DATA SR2/1.4142136D0/
35861       DATA KFNCHI/1000022,1000023,1000025,1000035/
35862       DATA KFCCHI/1000024,1000037/
35863
35864 C...COUNT THE NUMBER OF DECAY MODES
35865       LKNT=0
35866
35867       XMW=PMAS(24,1)
35868       XMW2=XMW**2
35869       XMZ=PMAS(23,1)
35870       XMZ2=XMZ**2
35871       XW=1D0-XMW2/XMZ2
35872       XW1=1D0-XW
35873       TANW = SQRT(XW/XW1)
35874
35875 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
35876       IX=1
35877       IF(KFIN.EQ.KFNCHI(2)) IX=2
35878       IF(KFIN.EQ.KFNCHI(3)) IX=3
35879       IF(KFIN.EQ.KFNCHI(4)) IX=4
35880
35881       XMI=SMZ(IX)
35882       XMI2=XMI**2
35883       AXMI=ABS(XMI)
35884       AEM=PYALEM(XMI2)
35885       AS =PYALPS(XMI2)
35886       C1=AEM/XW
35887       XMI3=ABS(XMI**3)
35888
35889       TANB=RMSS(5)
35890       BETA=ATAN(TANB)
35891       ALFA=RMSS(18)
35892       CBETA=COS(BETA)
35893       SBETA=TANB*CBETA
35894       CALFA=COS(ALFA)
35895       SALFA=SIN(ALFA)
35896
35897       DO 110 I=1,4
35898         DO 100 J=1,4
35899           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35900   100   CONTINUE
35901   110 CONTINUE
35902       DO 130 I=1,2
35903         DO 120 J=1,2
35904            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35905            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35906   120   CONTINUE
35907   130 CONTINUE
35908
35909 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35910       IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
35911
35912 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
35913       IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
35914         XMJ=SMZ(1)
35915         AXMJ=ABS(XMJ)
35916         LKNT=LKNT+1
35917         GAMCON=AEM**3/8D0/PI/XMW2/XW
35918         XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35919         XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
35920         XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
35921         IDLAM(LKNT,1)=KSUSY1+22
35922         IDLAM(LKNT,2)=22
35923         IDLAM(LKNT,3)=0
35924         WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
35925         GOTO 340
35926       ENDIF
35927
35928 C...GRAVITINO DECAY MODES
35929
35930       IF(IMSS(11).EQ.1) THEN
35931         XMP=RMSS(29)
35932         IDG=39+KSUSY1
35933         XMGR=PMAS(PYCOMP(IDG),1)
35934         SINW=SQRT(XW)
35935         COSW=SQRT(1D0-XW)
35936         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
35937         IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
35938           LKNT=LKNT+1
35939           IDLAM(LKNT,1)=IDG
35940           IDLAM(LKNT,2)=22
35941           IDLAM(LKNT,3)=0
35942           XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
35943         ENDIF
35944         IF(AXMI.GT.XMGR+XMZ) THEN
35945           LKNT=LKNT+1
35946           IDLAM(LKNT,1)=IDG
35947           IDLAM(LKNT,2)=23
35948           IDLAM(LKNT,3)=0
35949           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
35950      $  .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
35951      &  (1D0-XMZ2/XMI2)**4
35952         ENDIF
35953         IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
35954           LKNT=LKNT+1
35955           IDLAM(LKNT,1)=IDG
35956           IDLAM(LKNT,2)=25
35957           IDLAM(LKNT,3)=0
35958           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
35959      $  .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
35960         ENDIF
35961         IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
35962           LKNT=LKNT+1
35963           IDLAM(LKNT,1)=IDG
35964           IDLAM(LKNT,2)=35
35965           IDLAM(LKNT,3)=0
35966           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
35967      $  .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
35968         ENDIF
35969         IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
35970           LKNT=LKNT+1
35971           IDLAM(LKNT,1)=IDG
35972           IDLAM(LKNT,2)=36
35973           IDLAM(LKNT,3)=0
35974           XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
35975      $  .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
35976         ENDIF
35977         IF(IX.EQ.1) GOTO 300
35978       ENDIF
35979
35980       DO 220 IJ=1,IX-1
35981         XMJ=SMZ(IJ)
35982         AXMJ=ABS(XMJ)
35983         XMJ2=XMJ**2
35984
35985 C...CHI0_I -> CHI0_J + GAMMA
35986         IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
35987           RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
35988           RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
35989           RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
35990           RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
35991           IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
35992      &    (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
35993             LKNT=LKNT+1
35994             IDLAM(LKNT,1)=KFNCHI(IJ)
35995             IDLAM(LKNT,2)=22
35996             IDLAM(LKNT,3)=0
35997             GAMCON=AEM**3/8D0/PI/XMW2/XW
35998             XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35999             XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
36000             XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
36001           ENDIF
36002         ENDIF
36003
36004 C...CHI0_I -> CHI0_J + Z0
36005         IF(AXMI.GE.AXMJ+XMZ) THEN
36006           LKNT=LKNT+1
36007           OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36008      &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36009           ORPP=-DCONJG(OLPP)
36010           GX2=ABS(OLPP)**2+ABS(ORPP)**2
36011           GLR=DBLE(OLPP*DCONJG(ORPP))
36012           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36013           IDLAM(LKNT,1)=KFNCHI(IJ)
36014           IDLAM(LKNT,2)=23
36015           IDLAM(LKNT,3)=0
36016         ELSEIF(AXMI.GE.AXMJ) THEN
36017           XXC(1)=0D0
36018           XXC(2)=XMJ
36019           XXC(3)=0D0
36020           XXC(4)=XMI
36021           XXC(9)=XMZ
36022           XXC(10)=PMAS(23,2)
36023           OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36024      &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36025           ORPP=DCONJG(OLPP)
36026 C...CHARGED LEPTONS
36027           FID=11
36028           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36029           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36030           EI=KCHG(FID,1)/3D0
36031           T3I=SIGN(1D0,EI+1D-6)/2D0
36032           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36033      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36034           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36035           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36036           CXC(2)=-GLIJ
36037           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36038           CXC(4)=DCONJG(GLIJ)
36039           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36040           CXC(6)=GRIJ
36041           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36042           CXC(8)=-DCONJG(GRIJ)
36043           S12MIN=0D0
36044           S12MAX=(AXMI-AXMJ)**2
36045           IF( XXC(5).LT.AXMI ) THEN
36046             XXC(5)=1D6
36047           ENDIF
36048           IF(XXC(6).LT.AXMI ) THEN
36049             XXC(6)=1D6
36050           ENDIF
36051           XXC(7)=XXC(5)
36052           XXC(8)=XXC(6)
36053
36054           IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36055             LKNT=LKNT+1
36056             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36057      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36058             IDLAM(LKNT,1)=KFNCHI(IJ)
36059             IDLAM(LKNT,2)=FID
36060             IDLAM(LKNT,3)=-FID
36061             IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36062               LKNT=LKNT+1
36063               XLAM(LKNT)=XLAM(LKNT-1)
36064               IDLAM(LKNT,1)=KFNCHI(IJ)
36065               IDLAM(LKNT,2)=13
36066               IDLAM(LKNT,3)=-13
36067             ENDIF
36068           ENDIF
36069   140     CONTINUE
36070           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36071             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36072             XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
36073           ELSE
36074             XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
36075             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36076           ENDIF
36077           IF( XXC(5).LT.AXMI ) THEN
36078             XXC(5)=1D6
36079           ENDIF
36080           IF(XXC(6).LT.AXMI ) THEN
36081             XXC(6)=1D6
36082           ENDIF
36083           XXC(7)=XXC(5)
36084           XXC(8)=XXC(6)
36085
36086           IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36087             LKNT=LKNT+1
36088             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36089      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36090             IDLAM(LKNT,1)=KFNCHI(IJ)
36091             IDLAM(LKNT,2)=15
36092             IDLAM(LKNT,3)=-15
36093           ENDIF
36094
36095 C...NEUTRINOS
36096   150     CONTINUE
36097           FID=12
36098           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36099           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36100           EI=KCHG(FID,1)/3D0
36101           T3I=SIGN(1D0,EI+1D-6)/2D0
36102           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36103      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36104           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36105           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36106           CXC(2)=-GLIJ
36107           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36108           CXC(4)=DCONJG(GLIJ)
36109           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36110           CXC(6)=GRIJ
36111           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36112           CXC(8)=-DCONJG(GRIJ)
36113           S12MIN=0D0
36114           S12MAX=(AXMI-AXMJ)**2
36115           IF( XXC(5).LT.AXMI ) THEN
36116             XXC(5)=1D6
36117           ENDIF
36118           IF( XXC(6).LT.AXMI ) THEN
36119             XXC(6)=1D6
36120           ENDIF
36121           XXC(7)=XXC(5)
36122           XXC(8)=XXC(6)
36123
36124           LKNT=LKNT+1
36125           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36126      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36127           IDLAM(LKNT,1)=KFNCHI(IJ)
36128           IDLAM(LKNT,2)=12
36129           IDLAM(LKNT,3)=-12
36130           LKNT=LKNT+1
36131           XLAM(LKNT)=XLAM(LKNT-1)
36132           IDLAM(LKNT,1)=KFNCHI(IJ)
36133           IDLAM(LKNT,2)=14
36134           IDLAM(LKNT,3)=-14
36135   160     CONTINUE
36136
36137           IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
36138      &    THEN
36139             XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
36140             IF( XXC(5).LT.AXMI ) THEN
36141               XXC(5)=1D6
36142             ENDIF
36143             XXC(7)=XXC(5)
36144             LKNT=LKNT+1
36145             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36146      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36147           ELSE
36148             LKNT=LKNT+1
36149             XLAM(LKNT)=XLAM(LKNT-1)
36150           ENDIF
36151           IDLAM(LKNT,1)=KFNCHI(IJ)
36152           IDLAM(LKNT,2)=16
36153           IDLAM(LKNT,3)=-16
36154 C...D-TYPE QUARKS
36155   170     CONTINUE
36156           FID=1
36157           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36158           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36159           EI=KCHG(FID,1)/3D0
36160           T3I=SIGN(1D0,EI+1D-6)/2D0
36161           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36162      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36163           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36164           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36165           CXC(2)=-GLIJ
36166           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36167           CXC(4)=DCONJG(GLIJ)
36168           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36169           CXC(6)=GRIJ
36170           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36171           CXC(8)=-DCONJG(GRIJ)
36172           S12MIN=0D0
36173           S12MAX=(AXMI-AXMJ)**2
36174           IF( XXC(5).LT.AXMI ) THEN
36175             XXC(5)=1D6
36176           ENDIF
36177           IF( XXC(6).LT.AXMI ) THEN
36178             XXC(6)=1D6
36179           ENDIF
36180           XXC(7)=XXC(5)
36181           XXC(8)=XXC(6)
36182
36183           IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36184             LKNT=LKNT+1
36185             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36186      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36187             IDLAM(LKNT,1)=KFNCHI(IJ)
36188             IDLAM(LKNT,2)=1
36189             IDLAM(LKNT,3)=-1
36190             IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36191               LKNT=LKNT+1
36192               XLAM(LKNT)=XLAM(LKNT-1)
36193               IDLAM(LKNT,1)=KFNCHI(IJ)
36194               IDLAM(LKNT,2)=3
36195               IDLAM(LKNT,3)=-3
36196             ENDIF
36197           ENDIF
36198   180     CONTINUE
36199           IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36200             XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36201             XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36202           ELSE
36203             XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36204             XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36205           ENDIF
36206           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
36207           IF(XXC(5).LT.AXMI) THEN
36208             XXC(5)=1D6
36209           ELSEIF(XXC(6).LT.AXMI) THEN
36210             XXC(6)=1D6
36211           ENDIF
36212           XXC(7)=XXC(5)
36213           XXC(8)=XXC(6)
36214           IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36215             LKNT=LKNT+1
36216             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36217      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36218             IDLAM(LKNT,1)=KFNCHI(IJ)
36219             IDLAM(LKNT,2)=5
36220             IDLAM(LKNT,3)=-5
36221           ENDIF
36222
36223 C...U-TYPE QUARKS
36224   190     CONTINUE
36225           FID=2
36226           XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36227           XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36228           EI=KCHG(FID,1)/3D0
36229           T3I=SIGN(1D0,EI+1D-6)/2D0
36230           GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36231      &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36232           GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36233           CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36234           CXC(2)=-GLIJ
36235           CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36236           CXC(4)=DCONJG(GLIJ)
36237           CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36238           CXC(6)=GRIJ
36239           CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36240           CXC(8)=-DCONJG(GRIJ)
36241
36242           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
36243           IF(XXC(5).LT.AXMI) THEN
36244             XXC(5)=1D6
36245           ELSEIF(XXC(6).LT.AXMI) THEN
36246             XXC(6)=1D6
36247           ENDIF
36248           XXC(7)=XXC(5)
36249           XXC(8)=XXC(6)
36250
36251           IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36252             LKNT=LKNT+1
36253             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36254      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36255             IDLAM(LKNT,1)=KFNCHI(IJ)
36256             IDLAM(LKNT,2)=2
36257             IDLAM(LKNT,3)=-2
36258             IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36259               LKNT=LKNT+1
36260               XLAM(LKNT)=XLAM(LKNT-1)
36261               IDLAM(LKNT,1)=KFNCHI(IJ)
36262               IDLAM(LKNT,2)=4
36263               IDLAM(LKNT,3)=-4
36264             ENDIF
36265           ENDIF
36266   200     CONTINUE
36267         ENDIF
36268
36269 C...CHI0_I -> CHI0_J + H0_K
36270         EH(1)=SIN(ALFA)
36271         EH(2)=COS(ALFA)
36272         EH(3)=-SIN(BETA)
36273         DH(1)=COS(ALFA)
36274         DH(2)=-SIN(ALFA)
36275         DH(3)=COS(BETA)
36276         QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
36277      &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
36278      &  TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
36279      &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
36280         RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
36281      &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
36282      &  TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
36283      &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
36284         DO 210 IH=1,3
36285           XMH=PMAS(ITH(IH),1)
36286           XMH2=XMH**2
36287           IF(AXMI.GE.AXMJ+XMH) THEN
36288             LKNT=LKNT+1
36289             XL=PYLAMF(XMI2,XMJ2,XMH2)
36290             F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
36291             F12K=F21K
36292 C...SIGN OF MASSES I,J
36293             XMK=XMJ
36294             IF(IH.EQ.3) XMK=-XMK
36295             GX2=ABS(F21K)**2+ABS(F12K)**2
36296             GLR=DBLE(F21K*DCONJG(F12K))
36297             XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
36298             IDLAM(LKNT,1)=KFNCHI(IJ)
36299             IDLAM(LKNT,2)=ITH(IH)
36300             IDLAM(LKNT,3)=0
36301           ENDIF
36302   210   CONTINUE
36303   220 CONTINUE
36304
36305 C...CHI0_I -> CHI+_J + W-
36306       DO 260 IJ=1,2
36307         XMJ=SMW(IJ)
36308         AXMJ=ABS(XMJ)
36309         XMJ2=XMJ**2
36310         IF(AXMI.GE.AXMJ+XMW) THEN
36311           LKNT=LKNT+1
36312           CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36313      &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
36314           CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36315      &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
36316           GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
36317           GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
36318           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
36319           IDLAM(LKNT,1)=KFCCHI(IJ)
36320           IDLAM(LKNT,2)=-24
36321           IDLAM(LKNT,3)=0
36322           LKNT=LKNT+1
36323           XLAM(LKNT)=XLAM(LKNT-1)
36324           IDLAM(LKNT,1)=-KFCCHI(IJ)
36325           IDLAM(LKNT,2)=24
36326           IDLAM(LKNT,3)=0
36327         ELSEIF(AXMI.GE.AXMJ) THEN
36328           S12MIN=0D0
36329           S12MAX=(AXMI-AXMJ)**2
36330           RT2I = 1D0/SQRT(2D0)
36331           CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36332      &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
36333           CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36334      &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
36335           CXC(5)=DCMPLX(0D0,0D0)
36336           CXC(7)=DCMPLX(0D0,0D0)
36337           IA=11
36338           JA=12
36339           EI=KCHG(IA,1)/3D0
36340           T3I=SIGN(1D0,EI+1D-6)/2D0
36341           EJ=KCHG(JA,1)/3D0
36342           T3J=SIGN(1D0,EJ+1D-6)/2D0
36343           CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36344      &    TANW+ZMIXC(IX,2)*T3J)*RT2I
36345           CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36346      &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
36347           CXC(6)=DCMPLX(0D0,0D0)
36348           CXC(8)=DCMPLX(0D0,0D0)
36349           XXC(1)=0D0
36350           XXC(2)=XMJ
36351           XXC(3)=0D0
36352           XXC(4)=XMI
36353           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36354           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
36355           XXC(9)=PMAS(24,1)
36356           XXC(10)=PMAS(24,2)
36357           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
36358           IF(XXC(5).LT.AXMI) THEN
36359             XXC(5)=1D6
36360           ELSEIF(XXC(6).LT.AXMI) THEN
36361             XXC(6)=1D6
36362           ENDIF
36363           XXC(7)=XXC(6)
36364           XXC(8)=XXC(5)
36365           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
36366             LKNT=LKNT+1
36367             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36368      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36369             IDLAM(LKNT,1)=KFCCHI(IJ)
36370             IDLAM(LKNT,2)=11
36371             IDLAM(LKNT,3)=-12
36372             LKNT=LKNT+1
36373             XLAM(LKNT)=XLAM(LKNT-1)
36374             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36375             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36376             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36377             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
36378               LKNT=LKNT+1
36379               XLAM(LKNT)=XLAM(LKNT-1)
36380               IDLAM(LKNT,1)=KFCCHI(IJ)
36381               IDLAM(LKNT,2)=13
36382               IDLAM(LKNT,3)=-14
36383               LKNT=LKNT+1
36384               XLAM(LKNT)=XLAM(LKNT-1)
36385               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36386               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36387               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36388             ENDIF
36389           ENDIF
36390   230     CONTINUE
36391           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36392             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36393             XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36394           ELSE
36395             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36396             XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36397           ENDIF
36398           IF(XXC(5).LT.AXMI) THEN
36399             XXC(5)=1D6
36400           ENDIF
36401           IF(XXC(6).LT.AXMI) THEN
36402             XXC(6)=1D6
36403           ENDIF
36404           XXC(7)=XXC(6)
36405           XXC(8)=XXC(5)
36406           IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
36407             LKNT=LKNT+1
36408             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36409      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36410             XLAM(LKNT)=XLAM(LKNT-1)
36411             IDLAM(LKNT,1)=KFCCHI(IJ)
36412             IDLAM(LKNT,2)=15
36413             IDLAM(LKNT,3)=-16
36414             LKNT=LKNT+1
36415             XLAM(LKNT)=XLAM(LKNT-1)
36416             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36417             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36418             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36419           ENDIF
36420
36421 C...NOW, DO THE QUARKS
36422   240     CONTINUE
36423           IA=1
36424           JA=2
36425           EI=KCHG(IA,1)/3D0
36426           T3I=SIGN(1D0,EI+1D-6)/2D0
36427           EJ=KCHG(JA,1)/3D0
36428           T3J=SIGN(1D0,EJ+1D-6)/2D0
36429           CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36430      &    TANW+ZMIXC(IX,2)*T3J)
36431           CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36432      &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
36433           XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36434           XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
36435           IF(XXC(5).LT.AXMI) THEN
36436             XXC(5)=1D6
36437           ENDIF
36438           IF(XXC(6).LT.AXMI) THEN
36439             XXC(6)=1D6
36440           ENDIF
36441           XXC(7)=XXC(6)
36442           XXC(8)=XXC(5)
36443           IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
36444             LKNT=LKNT+1
36445             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36446      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36447             IDLAM(LKNT,1)=KFCCHI(IJ)
36448             IDLAM(LKNT,2)=1
36449             IDLAM(LKNT,3)=-2
36450             LKNT=LKNT+1
36451             XLAM(LKNT)=XLAM(LKNT-1)
36452             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36453             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36454             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36455             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36456               LKNT=LKNT+1
36457               XLAM(LKNT)=XLAM(LKNT-1)
36458               IDLAM(LKNT,1)=KFCCHI(IJ)
36459               IDLAM(LKNT,2)=3
36460               IDLAM(LKNT,3)=-4
36461               LKNT=LKNT+1
36462               XLAM(LKNT)=XLAM(LKNT-1)
36463               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36464               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36465               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36466             ENDIF
36467           ENDIF
36468   250     CONTINUE
36469         ENDIF
36470   260 CONTINUE
36471   270 CONTINUE
36472
36473 C...CHI0_I -> CHI+_I + H-
36474       DO 280 IJ=1,2
36475         XMJ=SMW(IJ)
36476         AXMJ=ABS(XMJ)
36477         XMJ2=XMJ**2
36478         XMHP=PMAS(ITHC,1)
36479         IF(AXMI.GE.AXMJ+XMHP) THEN
36480           LKNT=LKNT+1
36481           OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
36482      &    ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
36483           ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
36484      &    (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
36485      &    UMIXC(IJ,2)/SR2)
36486           GX2=ABS(OLPP)**2+ABS(ORPP)**2
36487           GLR=DBLE(OLPP*DCONJG(ORPP))
36488           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
36489           IDLAM(LKNT,1)=KFCCHI(IJ)
36490           IDLAM(LKNT,2)=-ITHC
36491           IDLAM(LKNT,3)=0
36492           LKNT=LKNT+1
36493           XLAM(LKNT)=XLAM(LKNT-1)
36494           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36495           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36496           IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36497         ELSE
36498
36499         ENDIF
36500   280 CONTINUE
36501
36502 C...2-BODY DECAYS TO FERMION SFERMION
36503       DO 290 J=1,16
36504         IF(J.GE.7.AND.J.LE.10) GOTO 290
36505         KF1=KSUSY1+J
36506         KF2=KSUSY2+J
36507         XMSF1=PMAS(PYCOMP(KF1),1)
36508         XMSF2=PMAS(PYCOMP(KF2),1)
36509         XMF=PMAS(J,1)
36510         IF(J.LE.6) THEN
36511           FCOL=3D0
36512         ELSE
36513           FCOL=1D0
36514         ENDIF
36515
36516         EI=KCHG(J,1)/3D0
36517         T3T=SIGN(1D0,EI)
36518         IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
36519         IF(MOD(J,2).EQ.0) THEN
36520           CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36521           CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
36522           CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36523           CBR=CAL
36524         ELSE
36525           CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36526           CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
36527           CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36528           CBR=CAL
36529         ENDIF
36530
36531 C...D~ D_L
36532         IF(AXMI.GE.XMF+XMSF1) THEN
36533           LKNT=LKNT+1
36534           XMA2=XMSF1**2
36535           XMB2=XMF**2
36536           XL=PYLAMF(XMI2,XMA2,XMB2)
36537           CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
36538           CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
36539           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36540      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36541           IDLAM(LKNT,1)=KF1
36542           IDLAM(LKNT,2)=-J
36543           IDLAM(LKNT,3)=0
36544           LKNT=LKNT+1
36545           XLAM(LKNT)=XLAM(LKNT-1)
36546           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36547           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36548           IDLAM(LKNT,3)=0
36549         ENDIF
36550
36551 C...D~ D_R
36552         IF(AXMI.GE.XMF+XMSF2) THEN
36553           LKNT=LKNT+1
36554           XMA2=XMSF2**2
36555           XMB2=XMF**2
36556           CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
36557           CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
36558           XL=PYLAMF(XMI2,XMA2,XMB2)
36559           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36560      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36561           IDLAM(LKNT,1)=KF2
36562           IDLAM(LKNT,2)=-J
36563           IDLAM(LKNT,3)=0
36564           LKNT=LKNT+1
36565           XLAM(LKNT)=XLAM(LKNT-1)
36566           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36567           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36568           IDLAM(LKNT,3)=0
36569         ENDIF
36570   290 CONTINUE
36571   300 CONTINUE
36572 C...3-BODY DECAY TO Q Q~ GLUINO
36573       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36574       IF(AXMI.GE.XMJ) THEN
36575         RT2I = 1D0/SQRT(2D0)
36576         OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
36577         ORPP=DCONJG(OLPP)
36578         AXMJ=ABS(XMJ)
36579         XXC(1)=0D0
36580         XXC(2)=XMJ
36581         XXC(3)=0D0
36582         XXC(4)=XMI
36583         FID=1
36584         XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36585         XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36586         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
36587         XXC(7)=XXC(5)
36588         XXC(8)=XXC(6)
36589         XXC(9)=1D6
36590         XXC(10)=0D0
36591         EI=KCHG(FID,1)/3D0
36592         T3I=SIGN(1D0,EI+1D-6)/2D0
36593         GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36594         GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36595         CXC(1)=0D0
36596         CXC(2)=-GLIJ
36597         CXC(3)=0D0
36598         CXC(4)=DCONJG(GLIJ)
36599         CXC(5)=0D0
36600         CXC(6)=GRIJ
36601         CXC(7)=0D0
36602         CXC(8)=-DCONJG(GRIJ)
36603         S12MIN=0D0
36604         S12MAX=(AXMI-AXMJ)**2
36605 C...ALL QUARKS BUT T
36606         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36607           LKNT=LKNT+1
36608           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
36609      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36610           IDLAM(LKNT,1)=KSUSY1+21
36611           IDLAM(LKNT,2)=1
36612           IDLAM(LKNT,3)=-1
36613           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36614             LKNT=LKNT+1
36615             XLAM(LKNT)=XLAM(LKNT-1)
36616             IDLAM(LKNT,1)=KSUSY1+21
36617             IDLAM(LKNT,2)=3
36618             IDLAM(LKNT,3)=-3
36619           ENDIF
36620         ENDIF
36621   310   CONTINUE
36622         IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36623           XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36624           XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36625         ELSE
36626           XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36627           XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36628         ENDIF
36629         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
36630         XXC(7)=XXC(5)
36631         XXC(8)=XXC(6)
36632         IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36633           LKNT=LKNT+1
36634           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36635      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36636           IDLAM(LKNT,1)=KSUSY1+21
36637           IDLAM(LKNT,2)=5
36638           IDLAM(LKNT,3)=-5
36639         ENDIF
36640 C...U-TYPE QUARKS
36641   320   CONTINUE
36642         FID=2
36643         XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36644         XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36645         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
36646         XXC(7)=XXC(5)
36647         XXC(8)=XXC(6)
36648         EI=KCHG(FID,1)/3D0
36649         T3I=SIGN(1D0,EI+1D-6)/2D0
36650         GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36651         GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36652         CXC(2)=-GLIJ
36653         CXC(4)=DCONJG(GLIJ)
36654         CXC(6)=GRIJ
36655         CXC(8)=-DCONJG(GRIJ)
36656         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36657           LKNT=LKNT+1
36658           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36659      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36660           IDLAM(LKNT,1)=KSUSY1+21
36661           IDLAM(LKNT,2)=2
36662           IDLAM(LKNT,3)=-2
36663           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36664             LKNT=LKNT+1
36665             XLAM(LKNT)=XLAM(LKNT-1)
36666             IDLAM(LKNT,1)=KSUSY1+21
36667             IDLAM(LKNT,2)=4
36668             IDLAM(LKNT,3)=-4
36669           ENDIF
36670         ENDIF
36671   330   CONTINUE
36672       ENDIF
36673
36674 C...R-violating decay modes (SKANDS).
36675       CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
36676
36677   340 IKNT=LKNT
36678       XLAM(0)=0D0
36679       DO 350 I=1,IKNT
36680         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36681         XLAM(0)=XLAM(0)+XLAM(I)
36682   350 CONTINUE
36683       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36684
36685       RETURN
36686       END
36687
36688 C*********************************************************************
36689
36690 C...PYCJDC
36691 C...Calculate decay widths for the charginos (admixtures of
36692 C...charged Wino and charged Higgsino.
36693
36694 C...Input:  KCIN = KF code for particle
36695 C...Output: XLAM = widths
36696 C...        IDLAM = KF codes for decay particles
36697 C...        IKNT = number of decay channels defined
36698 C...AUTHOR: STEPHEN MRENNA
36699 C...Last change:
36700 C...10-16-95:  force decay chi^+_1 -> chi^0_1 e+ nu_e
36701 C...when CHIENU .NE. 0
36702
36703       SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
36704
36705 C...Double precision and integer declarations.
36706       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36707       IMPLICIT INTEGER(I-N)
36708       INTEGER PYK,PYCHGE,PYCOMP
36709 C...Parameter statement to help give large particle numbers.
36710       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36711      &KEXCIT=4000000,KDIMEN=5000000)
36712 C...Commonblocks.
36713       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36714       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36715       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36716       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36717      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36718 CC     &SFMIX(16,4),
36719 C      COMMON/PYINTS/XXM(20)
36720       COMPLEX*16 CXC
36721       COMMON/PYINTC/XXC(10),CXC(8)
36722       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36723
36724 C...Local variables
36725       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
36726       COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
36727       INTEGER KFIN,KCIN
36728       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36729      &XMZ,XMZ2,AXMJ,AXMI
36730       DOUBLE PRECISION S12MIN,S12MAX
36731       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
36732       DOUBLE PRECISION PYLAMF,XL
36733       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
36734       DOUBLE PRECISION PYX2XH,PYX2XG
36735       DOUBLE PRECISION XLAM(0:300)
36736       INTEGER IDLAM(300,3)
36737       INTEGER LKNT,IX,IH,J,IJ,I,IKNT
36738       INTEGER ITH(3)
36739       INTEGER ITHC
36740       DOUBLE PRECISION ETAH(3),DH(3),EH(3)
36741       DOUBLE PRECISION SR2
36742       DOUBLE PRECISION CBETA,SBETA,TANB
36743
36744       DOUBLE PRECISION PYALEM,PI,PYALPS
36745       DOUBLE PRECISION FCOL
36746       INTEGER KF1,KF2,ISF
36747       INTEGER KFNCHI(4),KFCCHI(2)
36748
36749       DOUBLE PRECISION TEMP
36750       EXTERNAL PYGAUS,PYXXZ6
36751       DOUBLE PRECISION PYGAUS,PYXXZ6
36752       DOUBLE PRECISION PREC
36753       DATA ITH/25,35,36/
36754       DATA ITHC/37/
36755       DATA ETAH/1D0,1D0,-1D0/
36756       DATA SR2/1.4142136D0/
36757       DATA PI/3.141592654D0/
36758       DATA PREC/1D-2/
36759       DATA KFNCHI/1000022,1000023,1000025,1000035/
36760       DATA KFCCHI/1000024,1000037/
36761
36762 C...COUNT THE NUMBER OF DECAY MODES
36763       LKNT=0
36764       XMW=PMAS(24,1)
36765       XMW2=XMW**2
36766       XMZ=PMAS(23,1)
36767       XMZ2=XMZ**2
36768       XW=1D0-XMW2/XMZ2
36769       XW1=1D0-XW
36770       TANW = SQRT(XW/XW1)
36771
36772 C...1 OR 2 DEPENDING ON CHARGINO TYPE
36773       IX=1
36774       IF(KFIN.EQ.KFCCHI(2)) IX=2
36775       KCIN=PYCOMP(KFIN)
36776
36777       XMI=SMW(IX)
36778       XMI2=XMI**2
36779       AXMI=ABS(XMI)
36780       AEM=PYALEM(XMI2)
36781       AS =PYALPS(XMI2)
36782       C1=AEM/XW
36783       XMI3=ABS(XMI**3)
36784       TANB=RMSS(5)
36785       BETA=ATAN(TANB)
36786       CBETA=COS(BETA)
36787       SBETA=TANB*CBETA
36788       ALFA=RMSS(18)
36789
36790       DO 110 I=1,2
36791         DO 100 J=1,2
36792           VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
36793           UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
36794   100   CONTINUE
36795   110 CONTINUE
36796
36797 C...GRAVITINO DECAY MODES
36798
36799       IF(IMSS(11).EQ.1) THEN
36800         XMP=RMSS(29)
36801         IDG=39+KSUSY1
36802         XMGR=PMAS(PYCOMP(IDG),1)
36803 C        SINW=SQRT(XW)
36804 C        COSW=SQRT(1D0-XW)
36805         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36806         IF(AXMI.GT.XMGR+XMW) THEN
36807           LKNT=LKNT+1
36808           IDLAM(LKNT,1)=IDG
36809           IDLAM(LKNT,2)=24
36810           IDLAM(LKNT,3)=0
36811           XLAM(LKNT)=XFAC*(
36812      &  .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
36813      &  .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
36814      &  (1D0-XMW2/XMI2)**4
36815         ENDIF
36816         IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
36817           LKNT=LKNT+1
36818           IDLAM(LKNT,1)=IDG
36819           IDLAM(LKNT,2)=37
36820           IDLAM(LKNT,3)=0
36821           XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
36822      &   (ABS(UMIXC(IX,2))*SBETA)**2))
36823      &   *(1D0-PMAS(37,1)**2/XMI2)**4
36824        ENDIF
36825       ENDIF
36826
36827 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36828       IF(IX.EQ.1) GOTO 170
36829       XMJ=SMW(1)
36830       AXMJ=ABS(XMJ)
36831       XMJ2=XMJ**2
36832
36833 C...CHI_2+ -> CHI_1+ + Z0
36834       IF(AXMI.GE.AXMJ+XMZ) THEN
36835         LKNT=LKNT+1
36836         IJ=1
36837         OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36838      &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36839         ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36840      &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36841         GX2=ABS(OLPP)**2+ABS(ORPP)**2
36842         GLR=DBLE(OLPP*DCONJG(ORPP))
36843         XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36844         IDLAM(LKNT,1)=KFCCHI(1)
36845         IDLAM(LKNT,2)=23
36846         IDLAM(LKNT,3)=0
36847
36848 C...CHARGED LEPTONS
36849       ELSEIF(AXMI.GE.AXMJ) THEN
36850         S12MIN=0D0
36851         S12MAX=(AXMI-AXMJ)**2
36852         IA=11
36853         JA=12
36854         EI=KCHG(IABS(IA),1)/3D0
36855         T3I=SIGN(1D0,EI+1D-6)/2D0
36856         XXC(1)=0D0
36857         XXC(2)=XMJ
36858         XXC(3)=0D0
36859         XXC(4)=XMI
36860         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36861         XXC(6)=1D6
36862         XXC(9)=PMAS(23,1)
36863         XXC(10)=PMAS(23,2)
36864         IJ=1
36865         OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36866      &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36867         ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36868      &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36869         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36870         CXC(2)=DCMPLX(0D0,0D0)
36871         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36872         CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36873         CXC(5)=-DCMPLX(EI/XW1)*ORPP
36874         CXC(6)=DCMPLX(0D0,0D0)
36875         CXC(7)=-DCMPLX(EI/XW1)*OLPP
36876         CXC(8)=DCMPLX(0D0,0D0)
36877         IF( XXC(5).LT.AXMI ) THEN
36878           XXC(5)=1D6
36879         ENDIF
36880         XXC(7)=XXC(5)
36881         XXC(8)=XXC(6)
36882         IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36883           LKNT=LKNT+1
36884           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36885      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36886           IDLAM(LKNT,1)=KFCCHI(1)
36887           IDLAM(LKNT,2)=11
36888           IDLAM(LKNT,3)=-11
36889           IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36890             LKNT=LKNT+1
36891             XLAM(LKNT)=XLAM(LKNT-1)
36892             IDLAM(LKNT,1)=KFCCHI(1)
36893             IDLAM(LKNT,2)=13
36894             IDLAM(LKNT,3)=-13
36895           ENDIF
36896           IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36897             LKNT=LKNT+1
36898             XLAM(LKNT)=XLAM(LKNT-1)
36899             IDLAM(LKNT,1)=KFCCHI(1)
36900             IDLAM(LKNT,2)=15
36901             IDLAM(LKNT,3)=-15
36902           ENDIF
36903         ENDIF
36904
36905 C...NEUTRINOS
36906   120   CONTINUE
36907         IA=12
36908         JA=11
36909         EI=KCHG(IABS(IA),1)/3D0
36910         T3I=SIGN(1D0,EI+1D-6)/2D0
36911         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36912         XXC(6)=1D6
36913         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36914         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36915         CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
36916         CXC(5)=-DCMPLX(EI/XW1)*ORPP
36917         CXC(7)=-DCMPLX(EI/XW1)*OLPP
36918         IF( XXC(5).LT.AXMI ) THEN
36919           XXC(5)=1D6
36920         ENDIF
36921         XXC(7)=XXC(5)
36922         XXC(8)=XXC(6)
36923         IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
36924           LKNT=LKNT+1
36925           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36926      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36927           IDLAM(LKNT,1)=KFCCHI(1)
36928           IDLAM(LKNT,2)=12
36929           IDLAM(LKNT,3)=-12
36930           LKNT=LKNT+1
36931           XLAM(LKNT)=XLAM(LKNT-1)
36932           IDLAM(LKNT,1)=KFCCHI(1)
36933           IDLAM(LKNT,2)=14
36934           IDLAM(LKNT,3)=-14
36935         ENDIF
36936         IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
36937           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36938             XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36939           ELSE
36940             XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36941           ENDIF
36942           IF( XXC(5).LT.AXMI ) THEN
36943             XXC(5)=1D6
36944           ENDIF
36945           XXC(7)=XXC(5)
36946           LKNT=LKNT+1
36947           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36948      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36949           IDLAM(LKNT,1)=KFCCHI(1)
36950           IDLAM(LKNT,2)=16
36951           IDLAM(LKNT,3)=-16
36952         ENDIF
36953
36954 C...D-TYPE QUARKS
36955   130   CONTINUE
36956         IA=1
36957         JA=2
36958         EI=KCHG(IABS(IA),1)/3D0
36959         T3I=SIGN(1D0,EI+1D-6)/2D0
36960         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36961         XXC(6)=1D6
36962         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36963         CXC(2)=DCMPLX(0D0,0D0)
36964         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36965         CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36966         CXC(5)=-DCMPLX(EI/XW1)*ORPP
36967         CXC(6)=DCMPLX(0D0,0D0)
36968         CXC(7)=-DCMPLX(EI/XW1)*OLPP
36969         CXC(8)=DCMPLX(0D0,0D0)
36970         IF( XXC(5).LT.AXMI ) THEN
36971           XXC(5)=1D6
36972         ENDIF
36973         XXC(7)=XXC(5)
36974         XXC(8)=XXC(6)
36975         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36976           LKNT=LKNT+1
36977           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36978      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36979           IDLAM(LKNT,1)=KFCCHI(1)
36980           IDLAM(LKNT,2)=1
36981           IDLAM(LKNT,3)=-1
36982           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36983             LKNT=LKNT+1
36984             XLAM(LKNT)=XLAM(LKNT-1)
36985             IDLAM(LKNT,1)=KFCCHI(1)
36986             IDLAM(LKNT,2)=3
36987             IDLAM(LKNT,3)=-3
36988           ENDIF
36989         ENDIF
36990         IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36991           IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36992             XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36993           ELSE
36994             XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36995           ENDIF
36996           IF( XXC(5).LT.AXMI ) THEN
36997             XXC(5)=1D6
36998           ENDIF
36999           XXC(7)=XXC(5)
37000           LKNT=LKNT+1
37001           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37002      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37003           IDLAM(LKNT,1)=KFCCHI(1)
37004           IDLAM(LKNT,2)=5
37005           IDLAM(LKNT,3)=-5
37006         ENDIF
37007
37008 C...U-TYPE QUARKS
37009   140   CONTINUE
37010         IA=2
37011         JA=1
37012         EI=KCHG(IABS(IA),1)/3D0
37013         T3I=SIGN(1D0,EI+1D-6)/2D0
37014         XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37015         XXC(6)=1D6
37016         CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
37017         CXC(2)=DCMPLX(0D0,0D0)
37018         CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
37019         CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
37020         CXC(5)=-DCMPLX(EI/XW1)*ORPP
37021         CXC(6)=DCMPLX(0D0,0D0)
37022         CXC(7)=-DCMPLX(EI/XW1)*OLPP
37023         CXC(8)=DCMPLX(0D0,0D0)
37024         IF( XXC(5).LT.AXMI ) THEN
37025           XXC(5)=1D6
37026         ENDIF
37027         XXC(7)=XXC(5)
37028         XXC(8)=XXC(6)
37029         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37030           LKNT=LKNT+1
37031           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37032      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37033           IDLAM(LKNT,1)=KFCCHI(1)
37034           IDLAM(LKNT,2)=2
37035           IDLAM(LKNT,3)=-2
37036           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37037             LKNT=LKNT+1
37038             XLAM(LKNT)=XLAM(LKNT-1)
37039             IDLAM(LKNT,1)=KFCCHI(1)
37040             IDLAM(LKNT,2)=4
37041             IDLAM(LKNT,3)=-4
37042           ENDIF
37043         ENDIF
37044   150   CONTINUE
37045       ENDIF
37046
37047 C...CHI_2+ -> CHI_1+ + H0_K
37048       EH(2)=COS(ALFA)
37049       EH(1)=SIN(ALFA)
37050       EH(3)=-SBETA
37051       DH(2)=-SIN(ALFA)
37052       DH(1)=COS(ALFA)
37053       DH(3)=COS(BETA)
37054       DO 160 IH=1,3
37055         XMH=PMAS(ITH(IH),1)
37056         XMH2=XMH**2
37057 C...NO 3-BODY OPTION
37058         IF(AXMI.GE.AXMJ+XMH) THEN
37059           LKNT=LKNT+1
37060           XL=PYLAMF(XMI2,XMJ2,XMH2)
37061           OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
37062      &    VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
37063           ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
37064      &    DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
37065           XMK=XMJ*ETAH(IH)
37066           GX2=ABS(OLPP)**2+ABS(ORPP)**2
37067           GLR=DBLE(OLPP*DCONJG(ORPP))
37068           XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37069           IDLAM(LKNT,1)=KFCCHI(1)
37070           IDLAM(LKNT,2)=ITH(IH)
37071           IDLAM(LKNT,3)=0
37072         ENDIF
37073   160 CONTINUE
37074
37075 C...CHI1 JUMPS TO HERE
37076   170 CONTINUE
37077
37078 C...CHI+_I -> CHI0_J + W+
37079       DO 220 IJ=1,4
37080         XMJ=SMZ(IJ)
37081         AXMJ=ABS(XMJ)
37082         XMJ2=XMJ**2
37083         IF(AXMI.GE.AXMJ+XMW) THEN
37084           LKNT=LKNT+1
37085           DO 180 I=1,4
37086             ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37087   180     CONTINUE
37088           CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37089      &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
37090           CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37091      &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
37092           GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37093           GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37094           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37095           IDLAM(LKNT,1)=KFNCHI(IJ)
37096           IDLAM(LKNT,2)=24
37097           IDLAM(LKNT,3)=0
37098 C...LEPTONS
37099         ELSEIF(AXMI.GE.AXMJ) THEN
37100           S12MIN=0D0
37101           S12MAX=(AXMI-AXMJ)**2
37102           DO 190 I=1,4
37103             ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37104   190     CONTINUE
37105           CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37106      &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
37107           CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37108      &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
37109           CXC(5)=DCMPLX(0D0,0D0)
37110           CXC(7)=DCMPLX(0D0,0D0)
37111           IA=11
37112           JA=12
37113           EI=KCHG(IA,1)/3D0
37114           T3I=SIGN(1D0,EI+1D-6)/2D0
37115           EJ=KCHG(JA,1)/3D0
37116           T3J=SIGN(1D0,EJ+1D-6)/2D0
37117           CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
37118      &    TANW+ZMIXC(IJ,2)*T3J)/SR2
37119           CXC(4)=-DCONJG(UMIXC(IX,1))*(
37120      &    ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
37121           CXC(6)=DCMPLX(0D0,0D0)
37122           CXC(8)=DCMPLX(0D0,0D0)
37123           XXC(1)=0D0
37124           XXC(2)=XMJ
37125           XXC(3)=0D0
37126           XXC(4)=XMI
37127           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37128           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37129           XXC(9)=PMAS(24,1)
37130           XXC(10)=PMAS(24,2)
37131 CCC          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37132           IF(XXC(5).LT.AXMI) THEN
37133             XXC(5)=1D6
37134           ELSEIF(XXC(6).LT.AXMI) THEN
37135             XXC(6)=1D6
37136           ENDIF
37137           XXC(7)=XXC(6)
37138           XXC(8)=XXC(5)
37139 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
37140 C...--> 1/(16PI)/M**3*(AEM/XW)**2
37141           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37142             LKNT=LKNT+1
37143             TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37144             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37145             IDLAM(LKNT,1)=KFNCHI(IJ)
37146             IDLAM(LKNT,2)=-11
37147             IDLAM(LKNT,3)=12
37148 C...ONLY DECAY CHI+1 -> E+ NU_E
37149             IF( IMSS(12).NE. 0 ) GOTO 260
37150             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37151               LKNT=LKNT+1
37152               XLAM(LKNT)=XLAM(LKNT-1)
37153               IDLAM(LKNT,1)=KFNCHI(IJ)
37154               IDLAM(LKNT,2)=-13
37155               IDLAM(LKNT,3)=14
37156             ENDIF
37157           ENDIF
37158           IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37159             LKNT=LKNT+1
37160             IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37161               XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37162             ELSE
37163               XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37164             ENDIF
37165             XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37166             IF(XXC(5).LT.AXMI) THEN
37167               XXC(5)=1D6
37168             ELSEIF(XXC(6).LT.AXMI) THEN
37169               XXC(6)=1D6
37170             ENDIF
37171             XXC(7)=XXC(6)
37172             XXC(8)=XXC(5)
37173             TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37174             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37175             IDLAM(LKNT,1)=KFNCHI(IJ)
37176             IDLAM(LKNT,2)=-15
37177             IDLAM(LKNT,3)=16
37178           ENDIF
37179
37180 C...NOW, DO THE QUARKS
37181   200     CONTINUE
37182           IA=1
37183           JA=2
37184           EI=KCHG(IA,1)/3D0
37185           T3I=SIGN(1D0,EI+1D-6)/2D0
37186           EJ=KCHG(JA,1)/3D0
37187           T3J=SIGN(1D0,EJ+1D-6)/2D0
37188           CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37189      &    TANW+ZMIXC(IX,2)*T3J)
37190           CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37191      &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37192           XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37193           XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37194           IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
37195           IF(XXC(5).LT.AXMI) THEN
37196             XXC(5)=1D6
37197           ENDIF
37198           IF(XXC(6).LT.AXMI) THEN
37199             XXC(6)=1D6
37200           ENDIF
37201           XXC(7)=XXC(6)
37202           XXC(8)=XXC(5)
37203           IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37204             LKNT=LKNT+1
37205             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37206      &      PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37207             IDLAM(LKNT,1)=KFNCHI(IJ)
37208             IDLAM(LKNT,2)=-1
37209             IDLAM(LKNT,3)=2
37210             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37211               LKNT=LKNT+1
37212               XLAM(LKNT)=XLAM(LKNT-1)
37213               IDLAM(LKNT,1)=KFNCHI(IJ)
37214               IDLAM(LKNT,2)=-3
37215               IDLAM(LKNT,3)=4
37216             ENDIF
37217           ENDIF
37218   210     CONTINUE
37219         ENDIF
37220   220 CONTINUE
37221
37222 C...CHI+_I -> CHI0_J + H+
37223       DO 230 IJ=1,4
37224         XMJ=SMZ(IJ)
37225         AXMJ=ABS(XMJ)
37226         XMJ2=XMJ**2
37227         XMHP=PMAS(ITHC,1)
37228         IF(AXMI.GE.AXMJ+XMHP) THEN
37229           LKNT=LKNT+1
37230           OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
37231      &    ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
37232           ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
37233      &    (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
37234      &    UMIXC(IX,2)/SR2)
37235           GX2=ABS(OLPP)**2+ABS(ORPP)**2
37236           GLR=DBLE(OLPP*DCONJG(ORPP))
37237           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37238           IDLAM(LKNT,1)=KFNCHI(IJ)
37239           IDLAM(LKNT,2)=ITHC
37240           IDLAM(LKNT,3)=0
37241         ELSE
37242
37243         ENDIF
37244   230 CONTINUE
37245
37246 C...2-BODY DECAYS TO FERMION SFERMION
37247       DO 240 J=1,16
37248         IF(J.GE.7.AND.J.LE.10) GOTO 240
37249         IF(MOD(J,2).EQ.0) THEN
37250           KF1=KSUSY1+J-1
37251         ELSE
37252           KF1=KSUSY1+J+1
37253         ENDIF
37254         KF2=KF1+KSUSY1
37255         XMSF1=PMAS(PYCOMP(KF1),1)
37256         XMSF2=PMAS(PYCOMP(KF2),1)
37257         XMF=PMAS(J,1)
37258         IF(J.LE.6) THEN
37259           FCOL=3D0
37260         ELSE
37261           FCOL=1D0
37262         ENDIF
37263
37264 C...U~ D_L
37265         IF(MOD(J,2).EQ.0) THEN
37266           XMFP=PMAS(J-1,1)
37267           CAL=UMIXC(IX,1)
37268           CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
37269           CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
37270           CBR=0D0
37271           ISF=J-1
37272         ELSE
37273           XMFP=PMAS(J+1,1)
37274           CAL=VMIXC(IX,1)
37275           CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
37276           CBR=0D0
37277           CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
37278           ISF=J+1
37279         ENDIF
37280
37281 C...~U_L D
37282         IF(AXMI.GE.XMF+XMSF1) THEN
37283           LKNT=LKNT+1
37284           XMA2=XMSF1**2
37285           XMB2=XMF**2
37286           XL=PYLAMF(XMI2,XMA2,XMB2)
37287           CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
37288           CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
37289           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37290      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37291           IDLAM(LKNT,3)=0
37292           IF(MOD(J,2).EQ.0) THEN
37293             IDLAM(LKNT,1)=-KF1
37294             IDLAM(LKNT,2)=J
37295           ELSE
37296             IDLAM(LKNT,1)=KF1
37297             IDLAM(LKNT,2)=-J
37298           ENDIF
37299         ENDIF
37300
37301 C...U~ D_R
37302         IF(AXMI.GE.XMF+XMSF2) THEN
37303           LKNT=LKNT+1
37304           XMA2=XMSF2**2
37305           XMB2=XMF**2
37306           CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
37307           CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
37308           XL=PYLAMF(XMI2,XMA2,XMB2)
37309           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37310      &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37311           IDLAM(LKNT,3)=0
37312           IF(MOD(J,2).EQ.0) THEN
37313             IDLAM(LKNT,1)=-KF2
37314             IDLAM(LKNT,2)=J
37315           ELSE
37316             IDLAM(LKNT,1)=KF2
37317             IDLAM(LKNT,2)=-J
37318           ENDIF
37319         ENDIF
37320   240 CONTINUE
37321
37322 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
37323 C...A 2-BODY -- 2-BODY CHAIN
37324       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37325       IF(AXMI.GE.XMJ) THEN
37326         AXMJ=ABS(XMJ)
37327         S12MIN=0D0
37328         S12MAX=(AXMI-AXMJ)**2
37329         XXC(1)=0D0
37330         XXC(2)=XMJ
37331         XXC(3)=0D0
37332         XXC(4)=XMI
37333         XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
37334         XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
37335         XXC(9)=1D6
37336         XXC(10)=0D0
37337         OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
37338         ORPP=DCONJG(OLPP)
37339         CXC(1)=DCMPLX(0D0,0D0)
37340         CXC(3)=DCMPLX(0D0,0D0)
37341         CXC(5)=DCMPLX(0D0,0D0)
37342         CXC(7)=DCMPLX(0D0,0D0)
37343         CXC(2)=UMIXC(IX,1)*OLPP/SR2
37344         CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
37345         CXC(6)=DCMPLX(0D0,0D0)
37346         CXC(8)=DCMPLX(0D0,0D0)
37347         IF(XXC(5).LT.AXMI) THEN
37348           XXC(5)=1D6
37349         ELSEIF(XXC(6).LT.AXMI) THEN
37350           XXC(6)=1D6
37351         ENDIF
37352         XXC(7)=XXC(6)
37353         XXC(8)=XXC(5)
37354         IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
37355         IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37356           LKNT=LKNT+1
37357           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37358      &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37359           IDLAM(LKNT,1)=KSUSY1+21
37360           IDLAM(LKNT,2)=-1
37361           IDLAM(LKNT,3)=2
37362           IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37363             LKNT=LKNT+1
37364             XLAM(LKNT)=XLAM(LKNT-1)
37365             IDLAM(LKNT,1)=KSUSY1+21
37366             IDLAM(LKNT,2)=-3
37367             IDLAM(LKNT,3)=4
37368           ENDIF
37369         ENDIF
37370   250   CONTINUE
37371       ENDIF
37372
37373 C...R-violating decay modes (SKANDS).
37374       CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
37375
37376   260 IKNT=LKNT
37377       XLAM(0)=0D0
37378       DO 270 I=1,IKNT
37379         XLAM(0)=XLAM(0)+XLAM(I)
37380         IF(XLAM(I).LT.0D0) THEN
37381           WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
37382      &    (IDLAM(I,J),J=1,3)
37383           XLAM(I)=0D0
37384         ENDIF
37385   270 CONTINUE
37386       IF(XLAM(0).EQ.0D0) THEN
37387         XLAM(0)=1D-6
37388         WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
37389         WRITE(MSTU(11),*) LKNT
37390         WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
37391       ENDIF
37392
37393       RETURN
37394       END
37395
37396 C*********************************************************************
37397
37398 C...PYXXZ6
37399 C...Used in the calculation of  inoi -> inoj + f + ~f.
37400
37401       FUNCTION PYXXZ6(X)
37402
37403 C...Double precision and integer declarations.
37404       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37405       IMPLICIT INTEGER(I-N)
37406       INTEGER PYK,PYCHGE,PYCOMP
37407 C...Parameter statement to help give large particle numbers.
37408       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37409      &KEXCIT=4000000,KDIMEN=5000000)
37410 C...Commonblocks.
37411       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37412 C      COMMON/PYINTS/XXM(20)
37413       COMPLEX*16 CXC
37414       COMMON/PYINTC/XXC(10),CXC(8)
37415       SAVE /PYDAT1/,/PYINTC/
37416
37417 C...Local variables.
37418       COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
37419       DOUBLE PRECISION PYXXZ6,X
37420       DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
37421       DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
37422       DOUBLE PRECISION SIJ
37423       DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
37424       DOUBLE PRECISION OL2
37425       DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
37426       INTEGER I
37427
37428 C...Statement functions.
37429 C...Integral from x to y of (t-a)(b-t) dt.
37430       TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
37431 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
37432       TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
37433      &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
37434 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
37435       TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
37436      &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
37437 C...Integral from x to y of (t-a)/(b-t) dt.
37438       UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
37439 C...Integral from x to y of 1/(t-a) dt.
37440       TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
37441
37442       XM12=XXC(1)**2
37443       XM22=XXC(2)**2
37444       XM32=XXC(3)**2
37445       S=XXC(4)**2
37446       S13=X
37447
37448       S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
37449       S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
37450      &( (X-XM22-S)**2  -4D0*XM22*S  ) )
37451
37452       S23MIN=(S23AVE-S23DEL)
37453       S23MAX=(S23AVE+S23DEL)
37454
37455       XMSD1=XXC(5)**2
37456       XMSD2=XXC(7)**2
37457       XMSU1=XXC(6)**2
37458       XMSU2=XXC(8)**2
37459
37460       XMV=XXC(9)
37461       XMG=XXC(10)
37462       QLLS=CXC(1)
37463       QLLU=CXC(2)
37464       QLRS=CXC(3)
37465       QLRT=CXC(4)
37466       QRLS=CXC(5)
37467       QRLT=CXC(6)
37468       QRRS=CXC(7)
37469       QRRU=CXC(8)
37470       WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
37471       SIJ=2D0*XXC(2)*XXC(4)*S13
37472       IF(XMV.LE.1000D0) THEN
37473         OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
37474         OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
37475         WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
37476      &  +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
37477         IF(XXC(5).LE.10000D0) THEN
37478           WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
37479      &    TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
37480      &    .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
37481      &    DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
37482      &    .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
37483      &    *(S13-XMV**2)/WPROP2
37484         ELSE
37485           WFL1=0D0
37486         ENDIF
37487
37488         IF(XXC(6).LE.10000D0) THEN
37489           WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
37490      &    TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
37491      &    .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
37492      &    DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
37493      &    .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
37494      &    *(S13-XMV**2)/WPROP2
37495         ELSE
37496           WFL2=0D0
37497         ENDIF
37498       ELSE
37499         WW=0D0
37500         WFL1=0D0
37501         WFL2=0D0
37502       ENDIF
37503       IF(XXC(5).LE.10000D0) THEN
37504         WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
37505      &  +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
37506      &  - 2D0*DBLE(QLRT*DCONJG(QLLU))*
37507      &  SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
37508       ELSE
37509         WF1=0D0
37510       ENDIF
37511       IF(XXC(6).LE.10000D0) THEN
37512         WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
37513      &  +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
37514      &  - 2D0*DBLE(QRLT*DCONJG(QRRU))*
37515      &  SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
37516       ELSE
37517         WF2=0D0
37518       ENDIF
37519
37520       PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
37521
37522       IF(PYXXZ6.LT.0D0) THEN
37523         WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
37524         WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
37525         WRITE(MSTU(11),*) (XXc(I),I=5,8)
37526         WRITE(MSTU(11),*) (XXc(I),I=9,12)
37527         WRITE(MSTU(11),*) (XXc(I),I=13,16)
37528         WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
37529         WRITE(MSTU(11),*) S23MIN,S23MAX
37530         PYXXZ6=0D0
37531       ENDIF
37532
37533       RETURN
37534       END
37535
37536
37537 C*********************************************************************
37538
37539 C...PYXXGA
37540 C...Calculates chi0_i -> chi0_j + gamma.
37541
37542       FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
37543
37544 C...Double precision and integer declarations.
37545       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37546       IMPLICIT INTEGER(I-N)
37547       INTEGER PYK,PYCHGE,PYCOMP
37548
37549 C...Local variables.
37550       DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
37551       DOUBLE PRECISION F1,F2
37552
37553       F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
37554       F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
37555       PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
37556       PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
37557
37558       RETURN
37559       END
37560
37561 C*********************************************************************
37562
37563 C...PYX2XG
37564 C...Calculates the decay rate for ino -> ino + gauge boson.
37565
37566       FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
37567
37568 C...Double precision and integer declarations.
37569       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37570       IMPLICIT INTEGER(I-N)
37571       INTEGER PYK,PYCHGE,PYCOMP
37572
37573 C...Local variables.
37574       DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
37575       DOUBLE PRECISION XL,PYLAMF,C1
37576       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37577
37578       XMI2=XM1**2
37579       XMI3=ABS(XM1**3)
37580       XMJ2=XM2**2
37581       XMV2=XM3**2
37582       XL=PYLAMF(XMI2,XMJ2,XMV2)
37583       PYX2XG=C1/8D0/XMI3*SQRT(XL)
37584      &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
37585      &12D0*GLR*XM1*XM2*XMV2)
37586
37587       RETURN
37588       END
37589
37590 C*********************************************************************
37591
37592 C...PYX2XH
37593 C...Calculates the decay rate for ino -> ino + H.
37594
37595       FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
37596
37597 C...Double precision and integer declarations.
37598       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37599       IMPLICIT INTEGER(I-N)
37600       INTEGER PYK,PYCHGE,PYCOMP
37601
37602 C...Local variables.
37603       DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
37604       DOUBLE PRECISION XL,PYLAMF,C1
37605       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37606
37607       XMI2=XM1**2
37608       XMI3=ABS(XM1**3)
37609       XMJ2=XM2**2
37610       XMV2=XM3**2
37611       XL=PYLAMF(XMI2,XMJ2,XMV2)
37612       PYX2XH=C1/8D0/XMI3*SQRT(XL)
37613      &*(GX2*(XMI2+XMJ2-XMV2)+
37614      &4D0*GLR*XM1*XM2)
37615
37616       RETURN
37617       END
37618
37619 C*********************************************************************
37620
37621 C...PYHEXT
37622 C...Calculates the non-standard decay modes of the Higgs boson.
37623 C...
37624 C...Author:  Stephen Mrenna
37625 C...Last Update:  April 2001
37626 C......Allow complex values for Z,U, and V
37627
37628       SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
37629
37630 C...Double precision and integer declarations.
37631       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37632       IMPLICIT INTEGER(I-N)
37633       INTEGER PYK,PYCHGE,PYCOMP
37634 C...Parameter statement to help give large particle numbers.
37635       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37636      &KEXCIT=4000000,KDIMEN=5000000)
37637 C...Commonblocks.
37638       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37639       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37640       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37641       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37642       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37643      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37644       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
37645
37646 C...Local variables.
37647       COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
37648       COMPLEX*16 QIJ,RIJ,F21K,F12K
37649       INTEGER KFIN
37650       DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
37651       DOUBLE PRECISION XMI2,XMI3,XMJ2
37652       DOUBLE PRECISION PYLAMF,XL,CF,EI
37653       INTEGER IDU,IFL
37654       DOUBLE PRECISION TANW,XW,AEM,C1,AS
37655       DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
37656       DOUBLE PRECISION XLAM(0:300)
37657       INTEGER IDLAM(300,3)
37658       INTEGER LKNT,IH,J,IJ,I,IKNT,IK
37659       INTEGER ITH(4)
37660       INTEGER KFNCHI(4),KFCCHI(2)
37661       DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
37662       DOUBLE PRECISION SR2
37663       DOUBLE PRECISION BETA,ALFA
37664       DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
37665       DOUBLE PRECISION PYALEM
37666       DOUBLE PRECISION AL,AR,ALR
37667       DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
37668       DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
37669       DOUBLE PRECISION XMJL,XMJR,XM1,XM2
37670       DATA ITH/25,35,36,37/
37671       DATA ETAH/1D0,1D0,-1D0/
37672       DATA SR2/1.4142136D0/
37673       DATA KFNCHI/1000022,1000023,1000025,1000035/
37674       DATA KFCCHI/1000024,1000037/
37675
37676 C...COUNT THE NUMBER OF DECAY MODES
37677       LKNT=IKNT
37678
37679       XMW=PMAS(24,1)
37680       XMW2=XMW**2
37681       XMZ=PMAS(23,1)
37682       XW=PARU(102)
37683       TANW = SQRT(XW/(1D0-XW))
37684       CW=SQRT(1D0-XW)
37685
37686 C...1 - 4 DEPENDING ON Higgs species.
37687       IH=1
37688       IF(KFIN.EQ.ITH(2)) IH=2
37689       IF(KFIN.EQ.ITH(3)) IH=3
37690       IF(KFIN.EQ.ITH(4)) IH=4
37691
37692       XMI=PMAS(KFIN,1)
37693       XMI2=XMI**2
37694       AXMI=ABS(XMI)
37695       AEM=PYALEM(XMI2)
37696       C1=AEM/XW
37697       XMI3=ABS(XMI**3)
37698
37699       TANB=RMSS(5)
37700       BETA=ATAN(TANB)
37701       CBETA=COS(BETA)
37702       SBETA=TANB*CBETA
37703       ALFA=RMSS(18)
37704       COSA=COS(ALFA)
37705       SINA=SIN(ALFA)
37706       ATRIT=RMSS(16)
37707       ATRIB=RMSS(15)
37708       ATRIL=RMSS(17)
37709       XMUZ=-RMSS(4)
37710
37711       DO 110 I=1,4
37712         DO 100 J=1,4
37713           ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37714   100   CONTINUE
37715   110 CONTINUE
37716       DO 130 I=1,2
37717         DO 120 J=1,2
37718            VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37719            UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37720   120   CONTINUE
37721   130 CONTINUE
37722
37723
37724       IF(IH.EQ.4) GOTO 220
37725
37726 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37727 C...H0_K -> CHI0_I + CHI0_J
37728       EH(2)=SINA
37729       EH(1)=COSA
37730       EH(3)=CBETA
37731       DH(2)=COSA
37732       DH(1)=-SINA
37733       DH(3)=SBETA
37734       DO 150 IJ=1,4
37735         XMJ=SMZ(IJ)
37736         AXMJ=ABS(XMJ)
37737         DO 140 IK=1,IJ
37738           XMK=SMZ(IK)
37739           AXMK=ABS(XMK)
37740           IF(AXMI.GE.AXMJ+AXMK) THEN
37741             LKNT=LKNT+1
37742             QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
37743      &      ZMIXC(IJ,3)*ZMIXC(IK,2)-
37744      &      TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
37745      &      ZMIXC(IJ,3)*ZMIXC(IK,1))
37746             RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
37747      &      ZMIXC(IJ,4)*ZMIXC(IK,2)-
37748      &      TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
37749      &      ZMIXC(IJ,4)*ZMIXC(IK,1))
37750             F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
37751             F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
37752 C...SIGN OF MASSES I,J
37753             XML=XMK*ETAH(IH)
37754             GX2=ABS(F12K)**2+ABS(F21K)**2
37755             GLR=DBLE(F12K*DCONJG(F21K))
37756             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37757             IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
37758             IDLAM(LKNT,1)=KFNCHI(IJ)
37759             IDLAM(LKNT,2)=KFNCHI(IK)
37760             IDLAM(LKNT,3)=0
37761           ENDIF
37762   140   CONTINUE
37763   150 CONTINUE
37764
37765 C...H0_K -> CHI+_I CHI-_J
37766       DO 170 IJ=1,2
37767         XMJ=SMW(IJ)
37768         AXMJ=ABS(XMJ)
37769         DO 160 IK=1,2
37770           XMK=SMW(IK)
37771           AXMK=ABS(XMK)
37772           IF(AXMI.GE.AXMJ+AXMK) THEN
37773             LKNT=LKNT+1
37774             OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
37775      &      VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
37776             ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
37777      &      VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
37778             GX2=ABS(OLPP)**2+ABS(ORPP)**2
37779             GLR=DBLE(OLPP*DCONJG(ORPP))
37780             XML=XMK*ETAH(IH)
37781             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37782             IDLAM(LKNT,1)=KFCCHI(IJ)
37783             IDLAM(LKNT,2)=-KFCCHI(IK)
37784             IDLAM(LKNT,3)=0
37785           ENDIF
37786   160   CONTINUE
37787   170 CONTINUE
37788
37789 C...HIGGS TO SFERMION SFERMION
37790       DO 200 IFL=1,16
37791         IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
37792         IJ=KSUSY1+IFL
37793         XMJL=PMAS(PYCOMP(IJ),1)
37794         XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
37795         IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
37796           XMJ=XMJL
37797           XMJ2=XMJ**2
37798           XL=PYLAMF(XMI2,XMJ2,XMJ2)
37799           XMF=PMAS(IFL,1)
37800           EI=KCHG(IFL,1)/3D0
37801           IDU=2-MOD(IFL,2)
37802
37803           IF(IH.EQ.1) THEN
37804             IF(IDU.EQ.1) THEN
37805               GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
37806      &        XMF**2/XMW*SINA/CBETA
37807               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
37808      &        XMF**2/XMW*SINA/CBETA
37809               IF(IFL.EQ.5) THEN
37810                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37811      &          ATRIB*SINA)
37812               ELSEIF(IFL.EQ.15) THEN
37813                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37814      &          ATRIL*SINA)
37815               ELSE
37816                 GHLR=0D0
37817               ENDIF
37818             ELSE
37819               GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
37820      &        XMF**2/XMW*COSA/SBETA
37821               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
37822      &        XMF**2/XMW*COSA/SBETA
37823               IF(IFL.EQ.6) THEN
37824                 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
37825      &          ATRIT*COSA)
37826               ELSE
37827                 GHLR=0D0
37828               ENDIF
37829             ENDIF
37830
37831           ELSEIF(IH.EQ.2) THEN
37832             IF(IDU.EQ.1) THEN
37833               GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
37834      &        XMF**2/XMW*COSA/CBETA
37835               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37836      &        XMF**2/XMW*COSA/CBETA
37837               IF(IFL.EQ.5) THEN
37838                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37839      &          ATRIB*COSA)
37840               ELSEIF(IFL.EQ.15) THEN
37841                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37842      &          ATRIL*COSA)
37843               ELSE
37844                 GHLR=0D0
37845               ENDIF
37846             ELSE
37847               GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
37848      &        XMF**2/XMW*SINA/SBETA
37849               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37850      &        XMF**2/XMW*SINA/SBETA
37851               IF(IFL.EQ.6) THEN
37852                 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
37853      &          ATRIT*SINA)
37854               ELSE
37855                 GHLR=0D0
37856               ENDIF
37857             ENDIF
37858
37859           ELSEIF(IH.EQ.3) THEN
37860             GHLL=0D0
37861             GHRR=0D0
37862             GHLR=0D0
37863             IF(IDU.EQ.1) THEN
37864               IF(IFL.EQ.5) THEN
37865                 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
37866               ELSEIF(IFL.EQ.15) THEN
37867                 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
37868               ENDIF
37869             ELSE
37870               IF(IFL.EQ.6) THEN
37871                 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
37872               ENDIF
37873             ENDIF
37874           ENDIF
37875           IF(IH.EQ.3) GOTO 180
37876
37877           AL=SFMIX(IFL,1)**2
37878           AR=SFMIX(IFL,2)**2
37879           ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
37880           IF(IFL.LE.6) THEN
37881             CF=3D0
37882           ELSE
37883             CF=1D0
37884           ENDIF
37885
37886           IF(AXMI.GE.2D0*XMJ) THEN
37887             LKNT=LKNT+1
37888             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37889      &      (GHLL*AL+GHRR*AR
37890      &      +2D0*GHLR*ALR)**2
37891             IDLAM(LKNT,1)=IJ
37892             IDLAM(LKNT,2)=-IJ
37893             IDLAM(LKNT,3)=0
37894           ENDIF
37895
37896           IF(AXMI.GE.2D0*XMJR) THEN
37897             LKNT=LKNT+1
37898             AL=SFMIX(IFL,3)**2
37899             AR=SFMIX(IFL,4)**2
37900             ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
37901             XMJ=XMJR
37902             XMJ2=XMJ**2
37903             XL=PYLAMF(XMI2,XMJ2,XMJ2)
37904             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37905      &      (GHLL*AL+GHRR*AR
37906      &      +2D0*GHLR*ALR)**2
37907             IDLAM(LKNT,1)=IJ+KSUSY1
37908             IDLAM(LKNT,2)=-(IJ+KSUSY1)
37909             IDLAM(LKNT,3)=0
37910           ENDIF
37911   180     CONTINUE
37912
37913           IF(AXMI.GE.XMJL+XMJR) THEN
37914             LKNT=LKNT+1
37915             AL=SFMIX(IFL,1)*SFMIX(IFL,3)
37916             AR=SFMIX(IFL,2)*SFMIX(IFL,4)
37917             ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
37918             XMJ=XMJR
37919             XMJ2=XMJ**2
37920             XL=PYLAMF(XMI2,XMJ2,XMJL**2)
37921             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37922      &      (GHLL*AL+GHRR*AR)**2
37923             IDLAM(LKNT,1)=IJ
37924             IDLAM(LKNT,2)=-(IJ+KSUSY1)
37925             IDLAM(LKNT,3)=0
37926             LKNT=LKNT+1
37927             IDLAM(LKNT,1)=-IJ
37928             IDLAM(LKNT,2)=IJ+KSUSY1
37929             IDLAM(LKNT,3)=0
37930             XLAM(LKNT)=XLAM(LKNT-1)
37931           ENDIF
37932         ENDIF
37933   190   CONTINUE
37934   200 CONTINUE
37935   210 CONTINUE
37936
37937       GOTO 270
37938   220 CONTINUE
37939
37940 C...H+ -> CHI+_I + CHI0_J
37941       DO 240 IJ=1,4
37942         XMJ=SMZ(IJ)
37943         AXMJ=ABS(XMJ)
37944         XMJ2=XMJ**2
37945         DO 230 IK=1,2
37946           XMK=SMW(IK)
37947           AXMK=ABS(XMK)
37948           IF(AXMI.GE.AXMJ+AXMK) THEN
37949             LKNT=LKNT+1
37950             OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
37951      &      ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
37952             ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
37953      &      (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
37954             GX2=ABS(OLPP)**2+ABS(ORPP)**2
37955             GLR=DBLE(OLPP*DCONJG(ORPP))
37956             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
37957             IDLAM(LKNT,1)=KFNCHI(IJ)
37958             IDLAM(LKNT,2)=KFCCHI(IK)
37959             IDLAM(LKNT,3)=0
37960           ENDIF
37961   230   CONTINUE
37962   240 CONTINUE
37963
37964       GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
37965       GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
37966       AL=0D0
37967       AR=0D0
37968       CF=3D0
37969
37970 C...H+ -> T_1 B_1~
37971       XM1=PMAS(PYCOMP(KSUSY1+6),1)
37972       XM2=PMAS(PYCOMP(KSUSY1+5),1)
37973       IF(XMI.GE.XM1+XM2) THEN
37974         XL=PYLAMF(XMI2,XM1**2,XM2**2)
37975         LKNT=LKNT+1
37976         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37977      &  (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
37978         IDLAM(LKNT,1)=KSUSY1+6
37979         IDLAM(LKNT,2)=-(KSUSY1+5)
37980         IDLAM(LKNT,3)=0
37981       ENDIF
37982
37983 C...H+ -> T_2 B_1~
37984       XM1=PMAS(PYCOMP(KSUSY2+6),1)
37985       XM2=PMAS(PYCOMP(KSUSY1+5),1)
37986       IF(XMI.GE.XM1+XM2) THEN
37987         XL=PYLAMF(XMI2,XM1**2,XM2**2)
37988         LKNT=LKNT+1
37989         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37990      &  (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
37991         IDLAM(LKNT,1)=KSUSY2+6
37992         IDLAM(LKNT,2)=-(KSUSY1+5)
37993         IDLAM(LKNT,3)=0
37994       ENDIF
37995
37996 C...H+ -> T_1 B_2~
37997       XM1=PMAS(PYCOMP(KSUSY1+6),1)
37998       XM2=PMAS(PYCOMP(KSUSY2+5),1)
37999       IF(XMI.GE.XM1+XM2) THEN
38000         XL=PYLAMF(XMI2,XM1**2,XM2**2)
38001         LKNT=LKNT+1
38002         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38003      &  (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
38004         IDLAM(LKNT,1)=KSUSY1+6
38005         IDLAM(LKNT,2)=-(KSUSY2+5)
38006         IDLAM(LKNT,3)=0
38007       ENDIF
38008
38009 C...H+ -> T_2 B_2~
38010       XM1=PMAS(PYCOMP(KSUSY2+6),1)
38011       XM2=PMAS(PYCOMP(KSUSY2+5),1)
38012       IF(XMI.GE.XM1+XM2) THEN
38013         XL=PYLAMF(XMI2,XM1**2,XM2**2)
38014         LKNT=LKNT+1
38015         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38016      &  (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
38017         IDLAM(LKNT,1)=KSUSY2+6
38018         IDLAM(LKNT,2)=-(KSUSY2+5)
38019         IDLAM(LKNT,3)=0
38020       ENDIF
38021
38022 C...H+ -> UL DL~
38023       GL=-XMW/SR2*SIN(2D0*BETA)
38024       DO 250 IJ=1,3,2
38025         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38026         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38027         IF(XMI.GE.XM1+XM2) THEN
38028           XL=PYLAMF(XMI2,XM1**2,XM2**2)
38029           LKNT=LKNT+1
38030           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38031           IDLAM(LKNT,1)=-(KSUSY1+IJ)
38032           IDLAM(LKNT,2)=KSUSY1+IJ+1
38033           IDLAM(LKNT,3)=0
38034         ENDIF
38035   250 CONTINUE
38036
38037 C...H+ -> EL~ NUL
38038       CF=1D0
38039       DO 260 IJ=11,13,2
38040         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38041         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38042         IF(XMI.GE.XM1+XM2) THEN
38043           XL=PYLAMF(XMI2,XM1**2,XM2**2)
38044           LKNT=LKNT+1
38045           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38046           IDLAM(LKNT,1)=-(KSUSY1+IJ)
38047           IDLAM(LKNT,2)=KSUSY1+IJ+1
38048           IDLAM(LKNT,3)=0
38049         ENDIF
38050   260 CONTINUE
38051
38052 C...H+ -> TAU1 NUTAUL
38053       XM1=PMAS(PYCOMP(KSUSY1+15),1)
38054       XM2=PMAS(PYCOMP(KSUSY1+16),1)
38055       IF(XMI.GE.XM1+XM2) THEN
38056         XL=PYLAMF(XMI2,XM1**2,XM2**2)
38057         LKNT=LKNT+1
38058         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
38059         IDLAM(LKNT,1)=-(KSUSY1+15)
38060         IDLAM(LKNT,2)= KSUSY1+16
38061         IDLAM(LKNT,3)=0
38062       ENDIF
38063
38064 C...H+ -> TAU2 NUTAUL
38065       XM1=PMAS(PYCOMP(KSUSY2+15),1)
38066       XM2=PMAS(PYCOMP(KSUSY1+16),1)
38067       IF(XMI.GE.XM1+XM2) THEN
38068         XL=PYLAMF(XMI2,XM1**2,XM2**2)
38069         LKNT=LKNT+1
38070         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
38071         IDLAM(LKNT,1)=-(KSUSY2+15)
38072         IDLAM(LKNT,2)= KSUSY1+16
38073         IDLAM(LKNT,3)=0
38074       ENDIF
38075
38076   270 CONTINUE
38077       IKNT=LKNT
38078       XLAM(0)=0D0
38079       DO 280 I=1,IKNT
38080         IF(XLAM(I).LE.0D0) XLAM(I)=0D0
38081         XLAM(0)=XLAM(0)+XLAM(I)
38082   280 CONTINUE
38083       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
38084
38085       RETURN
38086       END
38087
38088 C*********************************************************************
38089
38090 C...PYH2XX
38091 C...Calculates the decay rate for a Higgs to an ino pair.
38092
38093       FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
38094
38095 C...Double precision and integer declarations.
38096       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38097       IMPLICIT INTEGER(I-N)
38098       INTEGER PYK,PYCHGE,PYCOMP
38099 C...Commonblocks.
38100       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38101       SAVE /PYDAT1/
38102
38103 C...Local variables.
38104       DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
38105       DOUBLE PRECISION XL,PYLAMF,C1
38106       DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
38107
38108       XMI2=XM1**2
38109       XMI3=ABS(XM1**3)
38110       XMJ2=XM2**2
38111       XMK2=XM3**2
38112       XL=PYLAMF(XMI2,XMJ2,XMK2)
38113       PYH2XX=C1/4D0/XMI3*SQRT(XL)
38114      &*(GX2*(XMI2-XMJ2-XMK2)-
38115      &4D0*GLR*XM3*XM2)
38116       IF(PYH2XX.LT.0D0) THEN
38117         WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
38118         WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
38119         STOP
38120       ENDIF
38121
38122       RETURN
38123       END
38124
38125 C*********************************************************************
38126
38127 C...PYGAUS
38128 C...Integration by adaptive Gaussian quadrature.
38129 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
38130
38131       FUNCTION PYGAUS(F, A, B, EPS)
38132
38133 C...Double precision and integer declarations.
38134       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38135       IMPLICIT INTEGER(I-N)
38136       INTEGER PYK,PYCHGE,PYCOMP
38137
38138 C...Local declarations.
38139       EXTERNAL F
38140       DOUBLE PRECISION F,W(12), X(12)
38141       DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
38142       DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
38143       DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
38144       DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
38145       DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
38146       DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
38147       DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
38148       DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
38149       DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
38150       DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
38151       DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
38152       DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
38153
38154 C...The Gaussian quadrature algorithm.
38155       H = 0D0
38156       IF(B .EQ. A) GOTO 140
38157       CONST = 5D-3 / ABS(B-A)
38158       BB = A
38159   100 CONTINUE
38160       AA = BB
38161       BB = B
38162   110 CONTINUE
38163       C1 = 0.5D0*(BB+AA)
38164       C2 = 0.5D0*(BB-AA)
38165       S8 = 0D0
38166       DO 120 I = 1, 4
38167         U = C2*X(I)
38168         S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
38169   120 CONTINUE
38170       S16 = 0D0
38171       DO 130 I = 5, 12
38172         U = C2*X(I)
38173         S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
38174   130 CONTINUE
38175       S16 = C2*S16
38176       IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
38177         H = H + S16
38178         IF(BB .NE. B) GOTO 100
38179       ELSE
38180         BB = C1
38181         IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
38182         H = 0D0
38183         CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
38184         GOTO 140
38185       ENDIF
38186   140 CONTINUE
38187       PYGAUS = H
38188
38189       RETURN
38190       END
38191
38192 C*********************************************************************
38193
38194 C...PYSIMP
38195 C...Simpson formula for an integral.
38196
38197       FUNCTION PYSIMP(Y,X0,X1,N)
38198
38199 C...Double precision and integer declarations.
38200       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38201       IMPLICIT INTEGER(I-N)
38202       INTEGER PYK,PYCHGE,PYCOMP
38203
38204 C...Local variables.
38205       DOUBLE PRECISION Y,X0,X1,H,S
38206       DIMENSION Y(0:N)
38207
38208       S=0D0
38209       H=(X1-X0)/N
38210       DO 100 I=0,N-2,2
38211         S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
38212   100 CONTINUE
38213       PYSIMP=S*H/3D0
38214
38215       RETURN
38216       END
38217
38218 C*********************************************************************
38219
38220 C...PYLAMF
38221 C...The standard lambda function.
38222
38223       FUNCTION PYLAMF(X,Y,Z)
38224
38225 C...Double precision and integer declarations.
38226       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38227       IMPLICIT INTEGER(I-N)
38228       INTEGER PYK,PYCHGE,PYCOMP
38229
38230 C...Local variables.
38231       DOUBLE PRECISION PYLAMF,X,Y,Z
38232
38233       PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
38234       IF(PYLAMF.LT.0D0) PYLAMF=0D0
38235
38236       RETURN
38237       END
38238
38239 C*********************************************************************
38240
38241 C...PYTBDY
38242 C...Generates 3-body decays of gauginos.
38243
38244       SUBROUTINE PYTBDY(IDIN)
38245
38246 C...Double precision and integer declarations.
38247       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38248       IMPLICIT INTEGER(I-N)
38249       INTEGER PYK,PYCHGE,PYCOMP
38250 C...Parameter statement to help give large particle numbers.
38251       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38252      &KEXCIT=4000000,KDIMEN=5000000)
38253 C...Commonblocks.
38254       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38255       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38256       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38257 C     COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38258 C     COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38259       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38260      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38261 C     SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
38262       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
38263
38264 C...Local variables.
38265       DOUBLE PRECISION XM(5)
38266       COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
38267       COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
38268       COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
38269       DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
38270       DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
38271       DOUBLE PRECISION CPHI1,SPHI1
38272       DOUBLE PRECISION S23DEL,EPS
38273       DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
38274       PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
38275       DOUBLE PRECISION F1,F2,X0,X1,X2,X3
38276       INTEGER INOID(4)
38277       DATA INOID/22,23,25,35/
38278       DATA EPS/1D-6/
38279
38280       ID=IDIN
38281       ISKIP=1
38282       XM(1)=P(N+1,5)
38283       XM(2)=P(N+2,5)
38284       XM(3)=P(N+3,5)
38285       XM(5)=P(ID,5)
38286
38287 C...GENERATE S12
38288       S12MIN=(XM(1)+XM(2))**2
38289       S12MAX=(XM(5)-XM(3))**2
38290       YJACO1=S12MAX-S12MIN
38291
38292 C...Initialize some parameters
38293       XW=PARU(102)
38294       XW1=1D0-XW
38295       TANW=SQRT(XW/XW1)
38296       IZID1=0
38297       IWID1=0
38298       IZID2=0
38299       IWID2=0
38300       DO 100 I1=1,4
38301         IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
38302         IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
38303   100 CONTINUE
38304       IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
38305       IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
38306       IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
38307       IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
38308       IA=K(N+2,2)
38309       JA=K(N+3,2)
38310       ZM12=XM(5)**2
38311       ZM22=XM(1)**2
38312       EI=KCHG(IABS(IA),1)/3D0
38313       T3I=SIGN(1D0,EI+1D-6)/2D0
38314       IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
38315         ISKIP=0
38316       ELSEIF(IZID1*IZID2.NE.0) THEN
38317         SQMZ=PMAS(23,1)**2
38318         GMMZ=PMAS(23,1)*PMAS(23,2)
38319         DO 110 I=1,4
38320           ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
38321           ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38322   110   CONTINUE
38323         OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
38324      &  ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
38325         ORPP=DCONJG(OLPP)
38326         XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
38327         XLR2=XLL2
38328         XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
38329         XRL2=XRR2
38330         GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
38331      &  DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
38332         GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
38333         XM1M2=SMZ(IZID1)*SMZ(IZID2)
38334         QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
38335         QLLU=-GLIJ
38336         QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
38337         QLRT=DCONJG(GLIJ)
38338         QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
38339         QRLT=GRIJ
38340         QRRS=DCMPLX((EI*XW)/XW1)*ORPP
38341         QRRU=-DCONJG(GRIJ)
38342       ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
38343         IF(IZID1.NE.0) THEN
38344           XM1M2=SMZ(IZID1)*SMW(IWID2)
38345           IZID1=IWID2
38346           IZID2=IZID1
38347         ELSE
38348           XM1M2=SMZ(IZID2)*SMW(IWID1)
38349           IZID1=IWID1
38350         ENDIF
38351         RT2I = 1D0/SQRT(2D0)
38352         SQMZ=PMAS(24,1)**2
38353         GMMZ=PMAS(24,1)*PMAS(24,2)
38354         DO 120 I=1,2
38355           VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38356           UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38357   120   CONTINUE
38358         DO 130 I=1,4
38359           ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38360   130   CONTINUE
38361         QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
38362      &  DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
38363         QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
38364      &  ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
38365         EJ=KCHG(JA,1)/3D0
38366         T3J=SIGN(1D0,EJ+1D-6)/2D0
38367         QRLS=DCMPLX(0D0,0D0)
38368         QRLT=QRLS
38369         QRRS=QRLS
38370         QRRU=QRLS
38371         XRR2=1D6**2
38372         XRL2=XRR2
38373         XLR2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
38374         XLL2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
38375         IF(MOD(IA,2).EQ.0) THEN
38376           QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
38377      &    TANW+ZMIXC(IZID2,2)*T3I)
38378           QLRT=-DCONJG(UMIXC(IZID1,1))*(
38379      &    ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
38380         ELSE
38381           QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
38382      &    TANW+ZMIXC(IZID2,2)*T3J)
38383           QLRT=-DCONJG(UMIXC(IZID1,1))*(
38384      &    ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
38385         ENDIF
38386       ELSEIF(IWID1*IWID2.NE.0) THEN
38387         IZID1=IWID1
38388         IZID2=IWID2
38389         XM1M2=SMW(IWID1)*SMW(IWID2)
38390         SQMZ=PMAS(23,1)**2
38391         GMMZ=PMAS(23,1)*PMAS(23,2)
38392         DO 140 I=1,2
38393           VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38394           UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38395           VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
38396           UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
38397   140   CONTINUE
38398         OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
38399      &  VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
38400         ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
38401      &  UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
38402         QRLS=-DCMPLX(EI/XW1)*ORPP
38403         QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38404         QRRS=-DCMPLX(EI/XW1)*OLPP
38405         QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38406         IF(MOD(IA,2).EQ.0) THEN
38407           XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
38408           QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
38409         ELSE
38410           XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
38411           QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
38412         ENDIF
38413       ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
38414      &THEN
38415         ISKIP=0
38416       ELSE
38417         ISKIP=0
38418       ENDIF
38419
38420       IF(ISKIP.NE.0) THEN
38421         WTMAX=0D0
38422         DO 160 KT=1,100
38423           S12=S12MIN+YJACO1*(KT-1)/99
38424           S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38425      &    *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38426           S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38427      &    -(2D0*XM(1)*XM(2))**2
38428           S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38429      &    -(2D0*XM(3)*XM(5))**2
38430           S23DF1=S23DF1*EPS
38431           S23DF2=S23DF2*EPS
38432           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38433           S23DEL=S23DEL/EPS
38434           S23MIN=S23AVE-S23DEL
38435           S23MAX=S23AVE+S23DEL
38436           YJACO2=S23MAX-S23MIN
38437           TH=S12
38438           DO 150 KS=1,100
38439             S23=S23MIN+YJACO2*(KS-1)/99
38440             SH=S23
38441             UH=ZM12+ZM22-SH-TH
38442             WU2 = (UH-ZM12)*(UH-ZM22)
38443             WT2 = (TH-ZM12)*(TH-ZM22)
38444             WS2 = XM1M2*SH
38445             PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38446             PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38447             QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38448             QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38449             QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38450             QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38451             WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38452      &      (ABS(QRL)**2+ABS(QLR)**2)*WT2+
38453      &      2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38454             IF(WT0.GT.WTMAX) WTMAX=WT0
38455   150     CONTINUE
38456   160   CONTINUE
38457
38458         WTMAX=WTMAX*1.05D0
38459       ENDIF
38460
38461 C...FIND S12*
38462       AX=S12MIN
38463       CX=S12MAX
38464       BX=S12MIN+0.5D0*YJACO1
38465       X0=AX
38466       X3=CX
38467       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
38468         X1=BX
38469         X2=BX+C*(CX-BX)
38470       ELSE
38471         X2=BX
38472         X1=BX-C*(BX-AX)
38473       ENDIF
38474
38475 C...SOLVE FOR F1 AND F2
38476       S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38477      &-(2D0*XM(1)*XM(2))**2
38478       S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38479      &-(2D0*XM(3)*XM(5))**2
38480       S23DF1=S23DF1*EPS
38481       S23DF2=S23DF2*EPS
38482       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38483       F1=-2D0*S23DEL/EPS
38484       S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38485      &-(2D0*XM(1)*XM(2))**2
38486       S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38487      &-(2D0*XM(3)*XM(5))**2
38488       S23DF1=S23DF1*EPS
38489       S23DF2=S23DF2*EPS
38490       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38491       F2=-2D0*S23DEL/EPS
38492
38493   170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
38494 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
38495         IF(F2.LE.F1)THEN
38496           X0=X1
38497           X1=X2
38498           X2=R*X1+C*X3
38499           F1=F2
38500           S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38501      &    -(2D0*XM(1)*XM(2))**2
38502           S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38503      &    -(2D0*XM(3)*XM(5))**2
38504           S23DF1=S23DF1*EPS
38505           S23DF2=S23DF2*EPS
38506           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38507           F2=-2D0*S23DEL/EPS
38508         ELSE
38509           X3=X2
38510           X2=X1
38511           X1=R*X2+C*X0
38512           F2=F1
38513           S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38514      &    -(2D0*XM(1)*XM(2))**2
38515           S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38516      &    -(2D0*XM(3)*XM(5))**2
38517           S23DF1=S23DF1*EPS
38518           S23DF2=S23DF2*EPS
38519           S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38520           F1=-2D0*S23DEL/EPS
38521         ENDIF
38522         GOTO 170
38523       ENDIF
38524 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
38525       IF(F1.LT.F2)THEN
38526         GOLDEN=-F1
38527         XMIN=X1
38528       ELSE
38529         GOLDEN=-F2
38530         XMIN=X2
38531       ENDIF
38532
38533       IKNT=0
38534   180 S12=S12MIN+PYR(0)*YJACO1
38535       IKNT=IKNT+1
38536 C...GENERATE S23
38537       S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38538      &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38539       S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38540      &-(2D0*XM(1)*XM(2))**2
38541       S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38542      &-(2D0*XM(3)*XM(5))**2
38543       S23DF1=S23DF1*EPS
38544       S23DF2=S23DF2*EPS
38545       S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38546       S23DEL=S23DEL/EPS
38547       S23MIN=S23AVE-S23DEL
38548       S23MAX=S23AVE+S23DEL
38549       YJACO2=S23MAX-S23MIN
38550       S23=S23MIN+PYR(0)*YJACO2
38551
38552 C...CHECK THE SAMPLING
38553       IF(IKNT.GT.100) THEN
38554         WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
38555         GOTO 190
38556       ENDIF
38557       IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
38558
38559       IF(ISKIP.EQ.0) GOTO 190
38560
38561       SH=S23
38562       TH=S12
38563       UH=ZM12+ZM22-SH-TH
38564
38565       WU2 = (UH-ZM12)*(UH-ZM22)
38566       WT2 = (TH-ZM12)*(TH-ZM22)
38567       WS2 = XM1M2*SH
38568       PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38569       PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38570
38571       QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38572       QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38573       QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38574       QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38575 c      QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
38576 c      QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
38577 c     &/DCMPLX(TH-XML2)
38578 c      QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
38579 c      QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
38580 c     &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
38581       WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38582      &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
38583      &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38584
38585       IF(WT.LT.PYR(0)*WTMAX) GOTO 180
38586       IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
38587
38588   190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
38589       D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
38590       D2=XM(5)-D1-D3
38591       P1=SQRT(D1*D1-XM(1)**2)
38592       P2=SQRT(D2*D2-XM(2)**2)
38593       P3=SQRT(D3*D3-XM(3)**2)
38594       CTHE1=2D0*PYR(0)-1D0
38595       ANG1=2D0*PYR(0)*PARU(1)
38596       CPHI1=COS(ANG1)
38597       SPHI1=SIN(ANG1)
38598       ARG=1D0-CTHE1**2
38599       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38600       STHE1=SQRT(ARG)
38601       P(N+1,1)=P1*STHE1*CPHI1
38602       P(N+1,2)=P1*STHE1*SPHI1
38603       P(N+1,3)=P1*CTHE1
38604       P(N+1,4)=D1
38605
38606 C...GET CPHI3
38607       ANG3=2D0*PYR(0)*PARU(1)
38608       CPHI3=COS(ANG3)
38609       SPHI3=SIN(ANG3)
38610       CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
38611       ARG=1D0-CTHE3**2
38612       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38613       STHE3=SQRT(ARG)
38614       P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
38615      &+P3*STHE3*SPHI3*SPHI1
38616      &+P3*CTHE3*STHE1*CPHI1
38617       P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
38618      &-P3*STHE3*SPHI3*CPHI1
38619      &+P3*CTHE3*STHE1*SPHI1
38620       P(N+3,3)=P3*STHE3*CPHI3*STHE1
38621      &+P3*CTHE3*CTHE1
38622       P(N+3,4)=D3
38623
38624       DO 200 I=1,3
38625         P(N+2,I)=-P(N+1,I)-P(N+3,I)
38626   200 CONTINUE
38627       P(N+2,4)=D2
38628
38629       RETURN
38630       END
38631
38632 C*********************************************************************
38633
38634 C...PYTECM
38635 C...Finds the s-hat dependent eigenvalues of the inverse propagator
38636 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
38637 C...phase space generation.
38638
38639       SUBROUTINE PYTECM(S1,S2)
38640
38641 C...Double precision and integer declarations.
38642       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38643       IMPLICIT INTEGER(I-N)
38644       INTEGER PYK,PYCHGE,PYCOMP
38645 C...Parameter statement to help give large particle numbers.
38646       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38647      &KEXCIT=4000000,KDIMEN=5000000)
38648 C...Commonblocks.
38649       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38650       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38651       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38652       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
38653
38654 C...Local variables.
38655       DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
38656      &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
38657      &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:300),WDTE(0:300,0:5)
38658       INTEGER i,j,ierr
38659
38660       SH=PMAS(PYCOMP(KTECHN+113),1)**2
38661       AEM=PYALEM(SH)
38662
38663       TANW=SQRT(PARU(102)/(1D0-PARU(102)))
38664       CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
38665       QUPD=2D0*PARP(143)-1D0
38666
38667       ALPRHT=2.91D0*(3D0/PARP(144))
38668       FAR=SQRT(AEM/ALPRHT)
38669       FAO=FAR*QUPD
38670       FZR=FAR*CT2W
38671       FZO=-FAO*TANW
38672
38673       AR(1,1) = SH
38674       AR(2,2) = SH-PMAS(23,1)**2
38675       AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
38676       AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
38677       AR(1,2) = 0D0
38678       AR(2,1) = 0D0
38679       AR(1,3) = -SH*FAR
38680       AR(3,1) = AR(1,3)
38681       AR(1,4) = -SH*FAO
38682       AR(4,1) = AR(1,4)
38683       AR(2,3) = -SH*FZR
38684       AR(3,2) = AR(2,3)
38685       AR(2,4) = -SH*FZO
38686       AR(4,2) = AR(2,4)
38687       AR(3,4) = 0D0
38688       AR(4,3) = 0D0
38689 CCCCCCCC
38690       DO 110 I=1,4
38691         DO 100 J=1,4
38692           AT(I,J)=0D0
38693   100   CONTINUE
38694   110 CONTINUE
38695       SHR=SQRT(SH)
38696       CALL PYWIDT(23,SH,WDTP,WDTE)
38697       AT(2,2) = WDTP(0)*SHR
38698       CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
38699       AT(3,3) = WDTP(0)*SHR
38700       CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
38701       AT(4,4) = WDTP(0)*SHR
38702 CCCC
38703       CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
38704       DO 120 I=1,4
38705         WI(I)=SQRT(ABS(SH-WR(I)))
38706         WR(I)=ABS(WR(I))
38707   120 CONTINUE
38708       R1=MIN(WR(1),WR(2),WR(3),WR(4))
38709       R2=1D20
38710       S1=0D0
38711       S2=0D0
38712       DO 130 I=1,4
38713         IF(ABS(WR(I)-R1).LT.1D-6) THEN
38714           S1=WI(I)
38715           GOTO 130
38716         ENDIF
38717         IF(WR(I).LE.R2) THEN
38718           R2=WR(I)
38719           S2=WI(I)
38720         ENDIF
38721   130 CONTINUE
38722       S1=S1**2
38723       S2=S2**2
38724       RETURN
38725       END
38726
38727 C*********************************************************************
38728
38729 C...PYEIGC
38730 C...Finds eigenvalues of a general complex matrix
38731 C
38732 C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
38733 C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
38734 C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
38735 C     OF A COMPLEX GENERAL MATRIX.
38736 C
38737 C     ON INPUT
38738 C
38739 C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
38740 C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38741 C        DIMENSION STATEMENT.
38742 C
38743 C        N  IS THE ORDER OF THE MATRIX  A=(AR,AI).
38744 C
38745 C        AR  AND  AI  CONTAIN THE REAL AND IMAGINARY PARTS,
38746 C        RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
38747 C
38748 C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
38749 C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
38750 C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
38751 C
38752 C     ON OUTPUT
38753 C
38754 C        WR  AND  WI  CONTAIN THE REAL AND IMAGINARY PARTS,
38755 C        RESPECTIVELY, OF THE EIGENVALUES.
38756 C
38757 C        ZR  AND  ZI  CONTAIN THE REAL AND IMAGINARY PARTS,
38758 C        RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
38759 C
38760 C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
38761 C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
38762 C           AND COMQR2.  THE NORMAL COMPLETION CODE IS ZERO.
38763 C
38764 C        FV1, FV2, AND  FV3  ARE TEMPORARY STORAGE ARRAYS.
38765 C
38766 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38767 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38768 C
38769 C     THIS VERSION DATED AUGUST 1983.
38770 C
38771
38772       SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
38773
38774       INTEGER N,NM,IS1,IS2,IERR,MATZ
38775       DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
38776      X       FV1(4),FV2(4),FV3(4)
38777       IF (N .LE. NM) GOTO 100
38778       IERR = 10 * N
38779       GOTO 120
38780 C
38781   100 CALL  PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
38782       CALL  PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
38783       IF (MATZ .NE. 0) GOTO 110
38784 C     .......... FIND EIGENVALUES ONLY ..........
38785       CALL  PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
38786       GOTO 120
38787 C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
38788   110 CALL  PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
38789       IF (IERR .NE. 0) GOTO 120
38790       CALL  PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
38791   120 RETURN
38792       END
38793
38794 C*********************************************************************
38795
38796 C...PYCMQR
38797 C...Auxiliary to PYEICG.
38798 C
38799 C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
38800 C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
38801 C     AND WILKINSON.
38802 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
38803 C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
38804 C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
38805 C
38806 C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
38807 C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
38808 C
38809 C     ON INPUT
38810 C
38811 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
38812 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38813 C          DIMENSION STATEMENT.
38814 C
38815 C        N IS THE ORDER OF THE MATRIX.
38816 C
38817 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
38818 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
38819 C          SET LOW=1, IGH=N.
38820 C
38821 C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
38822 C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
38823 C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
38824 C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
38825 C          THE REDUCTION BY  CORTH, IF PERFORMED.
38826 C
38827 C     ON OUTPUT
38828 C
38829 C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
38830 C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
38831 C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
38832 C          EIGENVECTORS IS TO BE PERFORMED.
38833 C
38834 C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
38835 C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
38836 C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
38837 C          FOR INDICES IERR+1,...,N.
38838 C
38839 C        IERR IS SET TO
38840 C          ZERO       FOR NORMAL RETURN,
38841 C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
38842 C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
38843 C
38844 C     CALLS PYCDIV FOR COMPLEX DIVISION.
38845 C     CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
38846 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
38847 C
38848 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38849 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38850 C
38851 C     THIS VERSION DATED AUGUST 1983.
38852 C
38853
38854       SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
38855
38856       INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
38857       DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
38858       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
38859      X       PYTHAG
38860
38861       IERR = 0
38862       IF (LOW .EQ. IGH) GOTO 130
38863 C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
38864       L = LOW + 1
38865 C
38866       DO 120 I = L, IGH
38867          LL = MIN0(I+1,IGH)
38868          IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
38869          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
38870          YR = HR(I,I-1) / NORM
38871          YI = HI(I,I-1) / NORM
38872          HR(I,I-1) = NORM
38873          HI(I,I-1) = 0.0D0
38874 C
38875          DO 100 J = I, IGH
38876             SI = YR * HI(I,J) - YI * HR(I,J)
38877             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
38878             HI(I,J) = SI
38879   100    CONTINUE
38880 C
38881          DO 110 J = LOW, LL
38882             SI = YR * HI(J,I) + YI * HR(J,I)
38883             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
38884             HI(J,I) = SI
38885   110    CONTINUE
38886 C
38887   120 CONTINUE
38888 C     .......... STORE ROOTS ISOLATED BY CBAL ..........
38889   130 DO 140 I = 1, N
38890          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
38891          WR(I) = HR(I,I)
38892          WI(I) = HI(I,I)
38893   140 CONTINUE
38894 C
38895       EN = IGH
38896       TR = 0.0D0
38897       TI = 0.0D0
38898       ITN = 30*N
38899 C     .......... SEARCH FOR NEXT EIGENVALUE ..........
38900   150 IF (EN .LT. LOW) GOTO 320
38901       ITS = 0
38902       ENM1 = EN - 1
38903 C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
38904 C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
38905   160 DO 170 LL = LOW, EN
38906          L = EN + LOW - LL
38907          IF (L .EQ. LOW) GOTO 180
38908          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
38909      X            + DABS(HR(L,L)) + DABS(HI(L,L))
38910          TST2 = TST1 + DABS(HR(L,L-1))
38911          IF (TST2 .EQ. TST1) GOTO 180
38912   170 CONTINUE
38913 C     .......... FORM SHIFT ..........
38914   180 IF (L .EQ. EN) GOTO 300
38915       IF (ITN .EQ. 0) GOTO 310
38916       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
38917       SR = HR(EN,EN)
38918       SI = HI(EN,EN)
38919       XR = HR(ENM1,EN) * HR(EN,ENM1)
38920       XI = HI(ENM1,EN) * HR(EN,ENM1)
38921       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
38922       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
38923       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
38924       CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
38925       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
38926       ZZR = -ZZR
38927       ZZI = -ZZI
38928   190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
38929       SR = SR - XR
38930       SI = SI - XI
38931       GOTO 210
38932 C     .......... FORM EXCEPTIONAL SHIFT ..........
38933   200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
38934       SI = 0.0D0
38935 C
38936   210 DO 220 I = LOW, EN
38937          HR(I,I) = HR(I,I) - SR
38938          HI(I,I) = HI(I,I) - SI
38939   220 CONTINUE
38940 C
38941       TR = TR + SR
38942       TI = TI + SI
38943       ITS = ITS + 1
38944       ITN = ITN - 1
38945 C     .......... REDUCE TO TRIANGLE (ROWS) ..........
38946       LP1 = L + 1
38947 C
38948       DO 240 I = LP1, EN
38949          SR = HR(I,I-1)
38950          HR(I,I-1) = 0.0D0
38951          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
38952          XR = HR(I-1,I-1) / NORM
38953          WR(I-1) = XR
38954          XI = HI(I-1,I-1) / NORM
38955          WI(I-1) = XI
38956          HR(I-1,I-1) = NORM
38957          HI(I-1,I-1) = 0.0D0
38958          HI(I,I-1) = SR / NORM
38959 C
38960          DO 230 J = I, EN
38961             YR = HR(I-1,J)
38962             YI = HI(I-1,J)
38963             ZZR = HR(I,J)
38964             ZZI = HI(I,J)
38965             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
38966             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
38967             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
38968             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
38969   230    CONTINUE
38970 C
38971   240 CONTINUE
38972 C
38973       SI = HI(EN,EN)
38974       IF (SI .EQ. 0.0D0) GOTO 250
38975       NORM = PYTHAG(HR(EN,EN),SI)
38976       SR = HR(EN,EN) / NORM
38977       SI = SI / NORM
38978       HR(EN,EN) = NORM
38979       HI(EN,EN) = 0.0D0
38980 C     .......... INVERSE OPERATION (COLUMNS) ..........
38981   250 DO 280 J = LP1, EN
38982          XR = WR(J-1)
38983          XI = WI(J-1)
38984 C
38985          DO 270 I = L, J
38986             YR = HR(I,J-1)
38987             YI = 0.0D0
38988             ZZR = HR(I,J)
38989             ZZI = HI(I,J)
38990             IF (I .EQ. J) GOTO 260
38991             YI = HI(I,J-1)
38992             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
38993   260       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
38994             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
38995             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
38996   270    CONTINUE
38997 C
38998   280 CONTINUE
38999 C
39000       IF (SI .EQ. 0.0D0) GOTO 160
39001 C
39002       DO 290 I = L, EN
39003          YR = HR(I,EN)
39004          YI = HI(I,EN)
39005          HR(I,EN) = SR * YR - SI * YI
39006          HI(I,EN) = SR * YI + SI * YR
39007   290 CONTINUE
39008 C
39009       GOTO 160
39010 C     .......... A ROOT FOUND ..........
39011   300 WR(EN) = HR(EN,EN) + TR
39012       WI(EN) = HI(EN,EN) + TI
39013       EN = ENM1
39014       GOTO 150
39015 C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39016 C                CONVERGED AFTER 30*N ITERATIONS ..........
39017   310 IERR = EN
39018   320 RETURN
39019       END
39020
39021 C*********************************************************************
39022
39023 C...PYCMQ2
39024 C...Auxiliary to PYEICG.
39025 C
39026 C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
39027 C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
39028 C     AND WILKINSON.
39029 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
39030 C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
39031 C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
39032 C
39033 C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
39034 C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
39035 C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
39036 C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
39037 C     THIS GENERAL MATRIX TO HESSENBERG FORM.
39038 C
39039 C     ON INPUT
39040 C
39041 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39042 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39043 C          DIMENSION STATEMENT.
39044 C
39045 C        N IS THE ORDER OF THE MATRIX.
39046 C
39047 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39048 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
39049 C          SET LOW=1, IGH=N.
39050 C
39051 C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
39052 C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
39053 C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
39054 C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
39055 C          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
39056 C
39057 C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
39058 C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
39059 C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
39060 C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
39061 C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
39062 C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
39063 C          ARBITRARY.
39064 C
39065 C     ON OUTPUT
39066 C
39067 C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
39068 C          HAVE BEEN DESTROYED.
39069 C
39070 C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
39071 C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
39072 C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
39073 C          FOR INDICES IERR+1,...,N.
39074 C
39075 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39076 C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
39077 C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
39078 C          THE EIGENVECTORS HAS BEEN FOUND.
39079 C
39080 C        IERR IS SET TO
39081 C          ZERO       FOR NORMAL RETURN,
39082 C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
39083 C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
39084 C
39085 C     CALLS PYCDIV FOR COMPLEX DIVISION.
39086 C     CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
39087 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
39088 C
39089 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39090 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39091 C
39092 C     THIS VERSION DATED OCTOBER 1989.
39093 C
39094 C  MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
39095 C  MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
39096 C
39097
39098       SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
39099
39100       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
39101      X        ITN,ITS,LOW,LP1,ENM1,IEND,IERR
39102       DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
39103      X       ORTR(4),ORTI(4)
39104       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
39105      X       PYTHAG
39106
39107       IERR = 0
39108 C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
39109       DO 110 J = 1, N
39110 C
39111          DO 100 I = 1, N
39112             ZR(I,J) = 0.0D0
39113             ZI(I,J) = 0.0D0
39114   100    CONTINUE
39115          ZR(J,J) = 1.0D0
39116   110 CONTINUE
39117 C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
39118 C                FROM THE INFORMATION LEFT BY CORTH ..........
39119       IEND = IGH - LOW - 1
39120       IF (IEND.LT.0) GOTO 220
39121       IF (IEND.EQ.0) GOTO 170
39122 C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
39123       DO 160 II = 1, IEND
39124          I = IGH - II
39125          IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
39126          IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
39127 C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
39128          NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
39129          IP1 = I + 1
39130 C
39131          DO 120 K = IP1, IGH
39132             ORTR(K) = HR(K,I-1)
39133             ORTI(K) = HI(K,I-1)
39134   120    CONTINUE
39135 C
39136          DO 150 J = I, IGH
39137             SR = 0.0D0
39138             SI = 0.0D0
39139 C
39140             DO 130 K = I, IGH
39141                SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
39142                SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
39143   130       CONTINUE
39144 C
39145             SR = SR / NORM
39146             SI = SI / NORM
39147 C
39148             DO 140 K = I, IGH
39149                ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
39150                ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
39151   140       CONTINUE
39152 C
39153   150    CONTINUE
39154 C
39155   160 CONTINUE
39156 C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
39157   170 L = LOW + 1
39158 C
39159       DO 210 I = L, IGH
39160          LL = MIN0(I+1,IGH)
39161          IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
39162          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
39163          YR = HR(I,I-1) / NORM
39164          YI = HI(I,I-1) / NORM
39165          HR(I,I-1) = NORM
39166          HI(I,I-1) = 0.0D0
39167 C
39168          DO 180 J = I, N
39169             SI = YR * HI(I,J) - YI * HR(I,J)
39170             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
39171             HI(I,J) = SI
39172   180    CONTINUE
39173 C
39174          DO 190 J = 1, LL
39175             SI = YR * HI(J,I) + YI * HR(J,I)
39176             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
39177             HI(J,I) = SI
39178   190    CONTINUE
39179 C
39180          DO 200 J = LOW, IGH
39181             SI = YR * ZI(J,I) + YI * ZR(J,I)
39182             ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
39183             ZI(J,I) = SI
39184   200    CONTINUE
39185 C
39186   210 CONTINUE
39187 C     .......... STORE ROOTS ISOLATED BY CBAL ..........
39188   220 DO 230 I = 1, N
39189          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
39190          WR(I) = HR(I,I)
39191          WI(I) = HI(I,I)
39192   230 CONTINUE
39193 C
39194       EN = IGH
39195       TR = 0.0D0
39196       TI = 0.0D0
39197       ITN = 30*N
39198 C     .......... SEARCH FOR NEXT EIGENVALUE ..........
39199   240 IF (EN .LT. LOW) GOTO 430
39200       ITS = 0
39201       ENM1 = EN - 1
39202 C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
39203 C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
39204   250 DO 260 LL = LOW, EN
39205          L = EN + LOW - LL
39206          IF (L .EQ. LOW) GOTO 270
39207          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
39208      X            + DABS(HR(L,L)) + DABS(HI(L,L))
39209          TST2 = TST1 + DABS(HR(L,L-1))
39210          IF (TST2 .EQ. TST1) GOTO 270
39211   260 CONTINUE
39212 C     .......... FORM SHIFT ..........
39213   270 IF (L .EQ. EN) GOTO 420
39214       IF (ITN .EQ. 0) GOTO 550
39215       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
39216       SR = HR(EN,EN)
39217       SI = HI(EN,EN)
39218       XR = HR(ENM1,EN) * HR(EN,ENM1)
39219       XI = HI(ENM1,EN) * HR(EN,ENM1)
39220       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
39221       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
39222       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
39223       CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
39224       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
39225       ZZR = -ZZR
39226       ZZI = -ZZI
39227   280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
39228       SR = SR - XR
39229       SI = SI - XI
39230       GOTO 300
39231 C     .......... FORM EXCEPTIONAL SHIFT ..........
39232   290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
39233       SI = 0.0D0
39234 C
39235   300 DO 310 I = LOW, EN
39236          HR(I,I) = HR(I,I) - SR
39237          HI(I,I) = HI(I,I) - SI
39238   310 CONTINUE
39239 C
39240       TR = TR + SR
39241       TI = TI + SI
39242       ITS = ITS + 1
39243       ITN = ITN - 1
39244 C     .......... REDUCE TO TRIANGLE (ROWS) ..........
39245       LP1 = L + 1
39246 C
39247       DO 330 I = LP1, EN
39248          SR = HR(I,I-1)
39249          HR(I,I-1) = 0.0D0
39250          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
39251          XR = HR(I-1,I-1) / NORM
39252          WR(I-1) = XR
39253          XI = HI(I-1,I-1) / NORM
39254          WI(I-1) = XI
39255          HR(I-1,I-1) = NORM
39256          HI(I-1,I-1) = 0.0D0
39257          HI(I,I-1) = SR / NORM
39258 C
39259          DO 320 J = I, N
39260             YR = HR(I-1,J)
39261             YI = HI(I-1,J)
39262             ZZR = HR(I,J)
39263             ZZI = HI(I,J)
39264             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
39265             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
39266             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
39267             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
39268   320    CONTINUE
39269 C
39270   330 CONTINUE
39271 C
39272       SI = HI(EN,EN)
39273       IF (SI .EQ. 0.0D0) GOTO 350
39274       NORM = PYTHAG(HR(EN,EN),SI)
39275       SR = HR(EN,EN) / NORM
39276       SI = SI / NORM
39277       HR(EN,EN) = NORM
39278       HI(EN,EN) = 0.0D0
39279       IF (EN .EQ. N) GOTO 350
39280       IP1 = EN + 1
39281 C
39282       DO 340 J = IP1, N
39283          YR = HR(EN,J)
39284          YI = HI(EN,J)
39285          HR(EN,J) = SR * YR + SI * YI
39286          HI(EN,J) = SR * YI - SI * YR
39287   340 CONTINUE
39288 C     .......... INVERSE OPERATION (COLUMNS) ..........
39289   350 DO 390 J = LP1, EN
39290          XR = WR(J-1)
39291          XI = WI(J-1)
39292 C
39293          DO 370 I = 1, J
39294             YR = HR(I,J-1)
39295             YI = 0.0D0
39296             ZZR = HR(I,J)
39297             ZZI = HI(I,J)
39298             IF (I .EQ. J) GOTO 360
39299             YI = HI(I,J-1)
39300             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39301   360       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39302             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39303             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39304   370    CONTINUE
39305 C
39306          DO 380 I = LOW, IGH
39307             YR = ZR(I,J-1)
39308             YI = ZI(I,J-1)
39309             ZZR = ZR(I,J)
39310             ZZI = ZI(I,J)
39311             ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39312             ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39313             ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39314             ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39315   380    CONTINUE
39316 C
39317   390 CONTINUE
39318 C
39319       IF (SI .EQ. 0.0D0) GOTO 250
39320 C
39321       DO 400 I = 1, EN
39322          YR = HR(I,EN)
39323          YI = HI(I,EN)
39324          HR(I,EN) = SR * YR - SI * YI
39325          HI(I,EN) = SR * YI + SI * YR
39326   400 CONTINUE
39327 C
39328       DO 410 I = LOW, IGH
39329          YR = ZR(I,EN)
39330          YI = ZI(I,EN)
39331          ZR(I,EN) = SR * YR - SI * YI
39332          ZI(I,EN) = SR * YI + SI * YR
39333   410 CONTINUE
39334 C
39335       GOTO 250
39336 C     .......... A ROOT FOUND ..........
39337   420 HR(EN,EN) = HR(EN,EN) + TR
39338       WR(EN) = HR(EN,EN)
39339       HI(EN,EN) = HI(EN,EN) + TI
39340       WI(EN) = HI(EN,EN)
39341       EN = ENM1
39342       GOTO 240
39343 C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
39344 C                VECTORS OF UPPER TRIANGULAR FORM ..........
39345   430 NORM = 0.0D0
39346 C
39347       DO 440 I = 1, N
39348 C
39349          DO 440 J = I, N
39350             TR = DABS(HR(I,J)) + DABS(HI(I,J))
39351             IF (TR .GT. NORM) NORM = TR
39352   440 CONTINUE
39353 C
39354       IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
39355 C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
39356       DO 500 NN = 2, N
39357          EN = N + 2 - NN
39358          XR = WR(EN)
39359          XI = WI(EN)
39360          HR(EN,EN) = 1.0D0
39361          HI(EN,EN) = 0.0D0
39362          ENM1 = EN - 1
39363 C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
39364          DO 490 II = 1, ENM1
39365             I = EN - II
39366             ZZR = 0.0D0
39367             ZZI = 0.0D0
39368             IP1 = I + 1
39369 C
39370             DO 450 J = IP1, EN
39371                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
39372                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
39373   450       CONTINUE
39374 C
39375             YR = XR - WR(I)
39376             YI = XI - WI(I)
39377             IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
39378                TST1 = NORM
39379                YR = TST1
39380   460          YR = 0.01D0 * YR
39381                TST2 = NORM + YR
39382                IF (TST2 .GT. TST1) GOTO 460
39383   470       CONTINUE
39384             CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
39385 C     .......... OVERFLOW CONTROL ..........
39386             TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
39387             IF (TR .EQ. 0.0D0) GOTO 490
39388             TST1 = TR
39389             TST2 = TST1 + 1.0D0/TST1
39390             IF (TST2 .GT. TST1) GOTO 490
39391             DO 480 J = I, EN
39392                HR(J,EN) = HR(J,EN)/TR
39393                HI(J,EN) = HI(J,EN)/TR
39394   480       CONTINUE
39395 C
39396   490    CONTINUE
39397 C
39398   500 CONTINUE
39399 C     .......... END BACKSUBSTITUTION ..........
39400 C     .......... VECTORS OF ISOLATED ROOTS ..........
39401       DO 520 I = 1, N
39402          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
39403 C
39404          DO 510 J = I, N
39405             ZR(I,J) = HR(I,J)
39406             ZI(I,J) = HI(I,J)
39407   510    CONTINUE
39408 C
39409   520 CONTINUE
39410 C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
39411 C                VECTORS OF ORIGINAL FULL MATRIX.
39412 C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
39413       DO 540 JJ = LOW, N
39414          J = N + LOW - JJ
39415          M = MIN0(J,IGH)
39416 C
39417          DO 540 I = LOW, IGH
39418             ZZR = 0.0D0
39419             ZZI = 0.0D0
39420 C
39421             DO 530 K = LOW, M
39422                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
39423                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
39424   530       CONTINUE
39425 C
39426             ZR(I,J) = ZZR
39427             ZI(I,J) = ZZI
39428   540 CONTINUE
39429 C
39430       GOTO 560
39431 C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39432 C                CONVERGED AFTER 30*N ITERATIONS ..........
39433   550 IERR = EN
39434   560 RETURN
39435       END
39436
39437 C*********************************************************************
39438
39439 C...PYCDIV
39440 C...Auxiliary to PYCMQR
39441 C
39442 C     COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
39443 C
39444
39445       SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
39446
39447       DOUBLE PRECISION AR,AI,BR,BI,CR,CI
39448       DOUBLE PRECISION S,ARS,AIS,BRS,BIS
39449
39450       S = DABS(BR) + DABS(BI)
39451       ARS = AR/S
39452       AIS = AI/S
39453       BRS = BR/S
39454       BIS = BI/S
39455       S = BRS**2 + BIS**2
39456       CR = (ARS*BRS + AIS*BIS)/S
39457       CI = (AIS*BRS - ARS*BIS)/S
39458       RETURN
39459       END
39460
39461 C*********************************************************************
39462
39463 C...PYCSRT
39464 C...Auxiliary to PYCMQR
39465 C
39466 C     (YR,YI) = COMPLEX DSQRT(XR,XI)
39467 C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
39468 C
39469
39470       SUBROUTINE PYCSRT(XR,XI,YR,YI)
39471
39472       DOUBLE PRECISION XR,XI,YR,YI
39473       DOUBLE PRECISION S,TR,TI,PYTHAG
39474
39475       TR = XR
39476       TI = XI
39477       S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
39478       IF (TR .GE. 0.0D0) YR = S
39479       IF (TI .LT. 0.0D0) S = -S
39480       IF (TR .LE. 0.0D0) YI = S
39481       IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
39482       IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
39483       RETURN
39484       END
39485
39486       DOUBLE PRECISION FUNCTION PYTHAG(A,B)
39487       DOUBLE PRECISION A,B
39488 C
39489 C     FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
39490 C
39491       DOUBLE PRECISION P,R,S,T,U
39492       P = DMAX1(DABS(A),DABS(B))
39493       IF (P .EQ. 0.0D0) GOTO 110
39494       R = (DMIN1(DABS(A),DABS(B))/P)**2
39495   100 CONTINUE
39496          T = 4.0D0 + R
39497          IF (T .EQ. 4.0D0) GOTO 110
39498          S = R/T
39499          U = 1.0D0 + 2.0D0*S
39500          P = U*P
39501          R = (S/U)**2 * R
39502       GOTO 100
39503   110 PYTHAG = P
39504       RETURN
39505       END
39506
39507 C*********************************************************************
39508
39509 C...PYCBAL
39510 C...Auxiliary to PYEICG
39511 C
39512 C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39513 C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
39514 C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39515 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39516 C
39517 C     THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
39518 C     EIGENVALUES WHENEVER POSSIBLE.
39519 C
39520 C     ON INPUT
39521 C
39522 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39523 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39524 C          DIMENSION STATEMENT.
39525 C
39526 C        N IS THE ORDER OF THE MATRIX.
39527 C
39528 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39529 C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
39530 C
39531 C     ON OUTPUT
39532 C
39533 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39534 C          RESPECTIVELY, OF THE BALANCED MATRIX.
39535 C
39536 C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
39537 C          ARE EQUAL TO ZERO IF
39538 C           (1) I IS GREATER THAN J AND
39539 C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
39540 C
39541 C        SCALE CONTAINS INFORMATION DETERMINING THE
39542 C           PERMUTATIONS AND SCALING FACTORS USED.
39543 C
39544 C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
39545 C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
39546 C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
39547 C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
39548 C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
39549 C                 = D(J,J)       J = LOW,...,IGH
39550 C                 = P(J)         J = IGH+1,...,N.
39551 C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
39552 C     THEN 1 TO LOW-1.
39553 C
39554 C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
39555 C
39556 C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
39557 C     CBAL  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
39558 C     K,L HAVE BEEN REVERSED.)
39559 C
39560 C     ARITHMETIC IS REAL THROUGHOUT.
39561 C
39562 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39563 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39564 C
39565 C     THIS VERSION DATED AUGUST 1983.
39566 C
39567
39568       SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
39569
39570       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
39571       DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
39572       DOUBLE PRECISION C,F,G,R,S,B2,RADIX
39573       LOGICAL NOCONV
39574
39575       RADIX = 16.0D0
39576 C
39577       B2 = RADIX * RADIX
39578       K = 1
39579       L = N
39580       GOTO 150
39581 C     .......... IN-LINE PROCEDURE FOR ROW AND
39582 C                COLUMN EXCHANGE ..........
39583   100 SCALE(M) = J
39584       IF (J .EQ. M) GOTO 130
39585 C
39586       DO 110 I = 1, L
39587          F = AR(I,J)
39588          AR(I,J) = AR(I,M)
39589          AR(I,M) = F
39590          F = AI(I,J)
39591          AI(I,J) = AI(I,M)
39592          AI(I,M) = F
39593   110 CONTINUE
39594 C
39595       DO 120 I = K, N
39596          F = AR(J,I)
39597          AR(J,I) = AR(M,I)
39598          AR(M,I) = F
39599          F = AI(J,I)
39600          AI(J,I) = AI(M,I)
39601          AI(M,I) = F
39602   120 CONTINUE
39603 C
39604   130 IF(IEXC.EQ.1) GOTO 140
39605       IF(IEXC.EQ.2) GOTO 180
39606 C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
39607 C                AND PUSH THEM DOWN ..........
39608   140 IF (L .EQ. 1) GOTO 320
39609       L = L - 1
39610 C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
39611   150 DO 170 JJ = 1, L
39612          J = L + 1 - JJ
39613 C
39614          DO 160 I = 1, L
39615             IF (I .EQ. J) GOTO 160
39616             IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
39617   160    CONTINUE
39618 C
39619          M = L
39620          IEXC = 1
39621          GOTO 100
39622   170 CONTINUE
39623 C
39624       GOTO 190
39625 C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
39626 C                AND PUSH THEM LEFT ..........
39627   180 K = K + 1
39628 C
39629   190 DO 210 J = K, L
39630 C
39631          DO 200 I = K, L
39632             IF (I .EQ. J) GOTO 200
39633             IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
39634   200    CONTINUE
39635 C
39636          M = K
39637          IEXC = 2
39638          GOTO 100
39639   210 CONTINUE
39640 C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
39641       DO 220 I = K, L
39642   220 SCALE(I) = 1.0D0
39643 C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
39644   230 NOCONV = .FALSE.
39645 C
39646       DO 310 I = K, L
39647          C = 0.0D0
39648          R = 0.0D0
39649 C
39650          DO 240 J = K, L
39651             IF (J .EQ. I) GOTO 240
39652             C = C + DABS(AR(J,I)) + DABS(AI(J,I))
39653             R = R + DABS(AR(I,J)) + DABS(AI(I,J))
39654   240    CONTINUE
39655 C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
39656          IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
39657          G = R / RADIX
39658          F = 1.0D0
39659          S = C + R
39660   250    IF (C .GE. G) GOTO 260
39661          F = F * RADIX
39662          C = C * B2
39663          GOTO 250
39664   260    G = R * RADIX
39665   270    IF (C .LT. G) GOTO 280
39666          F = F / RADIX
39667          C = C / B2
39668          GOTO 270
39669 C     .......... NOW BALANCE ..........
39670   280    IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
39671          G = 1.0D0 / F
39672          SCALE(I) = SCALE(I) * F
39673          NOCONV = .TRUE.
39674 C
39675          DO 290 J = K, N
39676             AR(I,J) = AR(I,J) * G
39677             AI(I,J) = AI(I,J) * G
39678   290    CONTINUE
39679 C
39680          DO 300 J = 1, L
39681             AR(J,I) = AR(J,I) * F
39682             AI(J,I) = AI(J,I) * F
39683   300    CONTINUE
39684 C
39685   310 CONTINUE
39686 C
39687       IF (NOCONV) GOTO 230
39688 C
39689   320 LOW = K
39690       IGH = L
39691       RETURN
39692       END
39693
39694 C*********************************************************************
39695
39696 C...PYCBA2
39697 C...Auxiliary to PYEICG.
39698 C
39699 C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39700 C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
39701 C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39702 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39703 C
39704 C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
39705 C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
39706 C     BALANCED MATRIX DETERMINED BY  CBAL.
39707 C
39708 C     ON INPUT
39709 C
39710 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39711 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39712 C          DIMENSION STATEMENT.
39713 C
39714 C        N IS THE ORDER OF THE MATRIX.
39715 C
39716 C        LOW AND IGH ARE INTEGERS DETERMINED BY  CBAL.
39717 C
39718 C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
39719 C          AND SCALING FACTORS USED BY  CBAL.
39720 C
39721 C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
39722 C
39723 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39724 C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
39725 C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
39726 C
39727 C     ON OUTPUT
39728 C
39729 C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39730 C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
39731 C          IN THEIR FIRST M COLUMNS.
39732 C
39733 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39734 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39735 C
39736 C     THIS VERSION DATED AUGUST 1983.
39737 C
39738
39739       SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
39740
39741       INTEGER I,J,K,M,N,II,NM,IGH,LOW
39742       DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
39743       DOUBLE PRECISION S
39744
39745       IF (M .EQ. 0) GOTO 150
39746       IF (IGH .EQ. LOW) GOTO 120
39747 C
39748       DO 110 I = LOW, IGH
39749          S = SCALE(I)
39750 C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
39751 C                IF THE FOREGOING STATEMENT IS REPLACED BY
39752 C                S=1.0D0/SCALE(I). ..........
39753          DO 100 J = 1, M
39754             ZR(I,J) = ZR(I,J) * S
39755             ZI(I,J) = ZI(I,J) * S
39756   100    CONTINUE
39757 C
39758   110 CONTINUE
39759 C     .......... FOR I=LOW-1 STEP -1 UNTIL 1,
39760 C                IGH+1 STEP 1 UNTIL N DO -- ..........
39761   120 DO 140 II = 1, N
39762          I = II
39763          IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
39764          IF (I .LT. LOW) I = LOW - II
39765          K = SCALE(I)
39766          IF (K .EQ. I) GOTO 140
39767 C
39768          DO 130 J = 1, M
39769             S = ZR(I,J)
39770             ZR(I,J) = ZR(K,J)
39771             ZR(K,J) = S
39772             S = ZI(I,J)
39773             ZI(I,J) = ZI(K,J)
39774             ZI(K,J) = S
39775   130    CONTINUE
39776 C
39777   140 CONTINUE
39778 C
39779   150 RETURN
39780       END
39781
39782 C*********************************************************************
39783
39784 C...PYCRTH
39785 C...Auxiliary to PYEICG.
39786 C
39787 C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
39788 C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
39789 C     BY MARTIN AND WILKINSON.
39790 C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
39791 C
39792 C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
39793 C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
39794 C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
39795 C     UNITARY SIMILARITY TRANSFORMATIONS.
39796 C
39797 C     ON INPUT
39798 C
39799 C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39800 C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39801 C          DIMENSION STATEMENT.
39802 C
39803 C        N IS THE ORDER OF THE MATRIX.
39804 C
39805 C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39806 C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
39807 C          SET LOW=1, IGH=N.
39808 C
39809 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39810 C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
39811 C
39812 C     ON OUTPUT
39813 C
39814 C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39815 C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
39816 C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
39817 C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
39818 C          HESSENBERG MATRIX.
39819 C
39820 C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
39821 C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
39822 C
39823 C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
39824 C
39825 C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39826 C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39827 C
39828 C     THIS VERSION DATED AUGUST 1983.
39829 C
39830
39831       SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
39832
39833       INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
39834       DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
39835       DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
39836
39837       LA = IGH - 1
39838       KP1 = LOW + 1
39839       IF (LA .LT. KP1) GOTO 210
39840 C
39841       DO 200 M = KP1, LA
39842          H = 0.0D0
39843          ORTR(M) = 0.0D0
39844          ORTI(M) = 0.0D0
39845          SCALE = 0.0D0
39846 C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
39847          DO 100 I = M, IGH
39848   100    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
39849 C
39850          IF (SCALE .EQ. 0.0D0) GOTO 200
39851          MP = M + IGH
39852 C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39853          DO 110 II = M, IGH
39854             I = MP - II
39855             ORTR(I) = AR(I,M-1) / SCALE
39856             ORTI(I) = AI(I,M-1) / SCALE
39857             H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
39858   110    CONTINUE
39859 C
39860          G = DSQRT(H)
39861          F = PYTHAG(ORTR(M),ORTI(M))
39862          IF (F .EQ. 0.0D0) GOTO 120
39863          H = H + F * G
39864          G = G / F
39865          ORTR(M) = (1.0D0 + G) * ORTR(M)
39866          ORTI(M) = (1.0D0 + G) * ORTI(M)
39867          GOTO 130
39868 C
39869   120    ORTR(M) = G
39870          AR(M,M-1) = SCALE
39871 C     .......... FORM (I-(U*UT)/H) * A ..........
39872   130    DO 160 J = M, N
39873             FR = 0.0D0
39874             FI = 0.0D0
39875 C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39876             DO 140 II = M, IGH
39877                I = MP - II
39878                FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
39879                FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
39880   140       CONTINUE
39881 C
39882             FR = FR / H
39883             FI = FI / H
39884 C
39885             DO 150 I = M, IGH
39886                AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
39887                AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
39888   150       CONTINUE
39889 C
39890   160    CONTINUE
39891 C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
39892          DO 190 I = 1, IGH
39893             FR = 0.0D0
39894             FI = 0.0D0
39895 C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
39896             DO 170 JJ = M, IGH
39897                J = MP - JJ
39898                FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
39899                FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
39900   170       CONTINUE
39901 C
39902             FR = FR / H
39903             FI = FI / H
39904 C
39905             DO 180 J = M, IGH
39906                AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
39907                AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
39908   180       CONTINUE
39909 C
39910   190    CONTINUE
39911 C
39912          ORTR(M) = SCALE * ORTR(M)
39913          ORTI(M) = SCALE * ORTI(M)
39914          AR(M,M-1) = -G * AR(M,M-1)
39915          AI(M,M-1) = -G * AI(M,M-1)
39916   200 CONTINUE
39917 C
39918   210 RETURN
39919       END
39920
39921 C*********************************************************************
39922
39923 C...PYLDCM
39924 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39925 C...processes.
39926
39927       SUBROUTINE PYLDCM(A,N,NP,INDX,D)
39928       IMPLICIT NONE
39929       INTEGER N,NP,INDX(N)
39930       REAL*8 D,TINY
39931       COMPLEX*16 A(NP,NP)
39932       PARAMETER (TINY=1.0D-20)
39933       INTEGER I,IMAX,J,K
39934       REAL*8 AAMAX,VV(6),DUM
39935       COMPLEX*16 SUM,DUMC
39936
39937       D=1D0
39938       DO 110 I=1,N
39939         AAMAX=0D0
39940         DO 100 J=1,N
39941           IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
39942   100   CONTINUE
39943         IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
39944         VV(I)=1D0/AAMAX
39945   110 CONTINUE
39946       DO 180 J=1,N
39947         DO 130 I=1,J-1
39948           SUM=A(I,J)
39949           DO 120 K=1,I-1
39950             SUM=SUM-A(I,K)*A(K,J)
39951   120     CONTINUE
39952           A(I,J)=SUM
39953   130   CONTINUE
39954         AAMAX=0D0
39955         DO 150 I=J,N
39956           SUM=A(I,J)
39957           DO 140 K=1,J-1
39958             SUM=SUM-A(I,K)*A(K,J)
39959   140     CONTINUE
39960           A(I,J)=SUM
39961           DUM=VV(I)*ABS(SUM)
39962           IF (DUM.GE.AAMAX) THEN
39963             IMAX=I
39964             AAMAX=DUM
39965           ENDIF
39966   150   CONTINUE
39967         IF (J.NE.IMAX)THEN
39968           DO 160 K=1,N
39969             DUMC=A(IMAX,K)
39970             A(IMAX,K)=A(J,K)
39971             A(J,K)=DUMC
39972   160     CONTINUE
39973           D=-D
39974           VV(IMAX)=VV(J)
39975         ENDIF
39976         INDX(J)=IMAX
39977         IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
39978         IF(J.NE.N)THEN
39979           DO 170 I=J+1,N
39980             A(I,J)=A(I,J)/A(J,J)
39981   170     CONTINUE
39982         ENDIF
39983   180 CONTINUE
39984
39985       RETURN
39986       END
39987
39988 C*********************************************************************
39989
39990 C...PYBKSB
39991 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39992 C...processes.
39993
39994       SUBROUTINE PYBKSB(A,N,NP,INDX,B)
39995       IMPLICIT NONE
39996       INTEGER N,NP,INDX(N)
39997       COMPLEX*16 A(NP,NP),B(N)
39998       INTEGER I,II,J,LL
39999       COMPLEX*16 SUM
40000
40001       II=0
40002       DO 110 I=1,N
40003         LL=INDX(I)
40004         SUM=B(LL)
40005         B(LL)=B(I)
40006         IF (II.NE.0)THEN
40007           DO 100 J=II,I-1
40008             SUM=SUM-A(I,J)*B(J)
40009   100     CONTINUE
40010         ELSE IF (ABS(SUM).NE.0D0) THEN
40011           II=I
40012         ENDIF
40013         B(I)=SUM
40014   110 CONTINUE
40015       DO 130 I=N,1,-1
40016         SUM=B(I)
40017         DO 120 J=I+1,N
40018           SUM=SUM-A(I,J)*B(J)
40019   120   CONTINUE
40020         B(I)=SUM/A(I,I)
40021   130 CONTINUE
40022       RETURN
40023       END
40024
40025 C***********************************************************************
40026
40027 C...PYWIDX
40028 C...Calculates full and partial widths of resonances.
40029 C....copy of PYWIDT, used for techniparticle widths
40030
40031       SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
40032
40033 C...Double precision and integer declarations.
40034       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40035       IMPLICIT INTEGER(I-N)
40036       INTEGER PYK,PYCHGE,PYCOMP
40037 C...Parameter statement to help give large particle numbers.
40038       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40039      &KEXCIT=4000000,KDIMEN=5000000)
40040 C...Commonblocks.
40041       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40042       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40043       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
40044       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
40045       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40046       COMMON/PYINT1/MINT(400),VINT(400)
40047       COMMON/PYINT4/MWID(500),WIDS(500,5)
40048       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40049       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
40050      &/PYINT4/,/PYMSSM/
40051 C...Local arrays and saved variables.
40052       DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
40053      &WID2SV(3,2)
40054       SAVE MOFSV,WIDWSV,WID2SV
40055       DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
40056
40057 C...Compressed code and sign; mass.
40058       KFLA=IABS(KFLR)
40059       KFLS=ISIGN(1,KFLR)
40060       KC=PYCOMP(KFLA)
40061       SHR=SQRT(SH)
40062       PMR=PMAS(KC,1)
40063
40064 C...Reset width information.
40065       DO 110 I=0,200
40066         WDTP(I)=0D0
40067         DO 100 J=0,5
40068           WDTE(I,J)=0D0
40069   100   CONTINUE
40070   110 CONTINUE
40071
40072 C...Common electroweak and strong constants.
40073       XW=PARU(102)
40074       XWV=XW
40075       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
40076       XW1=1D0-XW
40077       AEM=PYALEM(SH)
40078       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
40079       AS=PYALPS(SH)
40080       RADC=1D0+AS/PARU(1)
40081
40082       IF(KFLA.EQ.23) THEN
40083 C...Z0:
40084         ICASE=1
40085         XWC=1D0/(16D0*XW*XW1)
40086         FAC=(AEM*XWC/3D0)*SHR
40087   120   CONTINUE
40088         DO 130 I=1,MDCY(KC,3)
40089           IDC=I+MDCY(KC,2)-1
40090           IF(MDME(IDC,1).LT.0) GOTO 130
40091           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40092           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40093           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
40094           WID2=1D0
40095           IF(I.LE.8) THEN
40096 C...Z0 -> q + qbar
40097             EF=KCHG(I,1)/3D0
40098             AF=SIGN(1D0,EF+0.1D0)
40099             VF=AF-4D0*EF*XWV
40100             FCOF=3D0*RADC
40101             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
40102             IF(I.EQ.6) WID2=WIDS(6,1)
40103             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
40104           ELSEIF(I.LE.16) THEN
40105 C...Z0 -> l+ + l-, nu + nubar
40106             EF=KCHG(I+2,1)/3D0
40107             AF=SIGN(1D0,EF+0.1D0)
40108             VF=AF-4D0*EF*XWV
40109             FCOF=1D0
40110             IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
40111           ENDIF
40112           BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
40113             WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
40114      &      BE34
40115             WDTP(0)=WDTP(0)+WDTP(I)
40116           IF(MDME(IDC,1).GT.0) THEN
40117               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40118               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
40119      &        WDTE(I,MDME(IDC,1))
40120               WDTE(I,0)=WDTE(I,MDME(IDC,1))
40121               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40122           ENDIF
40123   130   CONTINUE
40124
40125
40126       ELSEIF(KFLA.EQ.24) THEN
40127 C...W+/-:
40128         FAC=(AEM/(24D0*XW))*SHR
40129         DO 140 I=1,MDCY(KC,3)
40130           IDC=I+MDCY(KC,2)-1
40131           IF(MDME(IDC,1).LT.0) GOTO 140
40132           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40133           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40134           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
40135           WID2=1D0
40136           IF(I.LE.16) THEN
40137 C...W+/- -> q + qbar'
40138             FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
40139             IF(KFLR.GT.0) THEN
40140               IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
40141               IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
40142               IF(I.GE.13) WID2=WID2*WIDS(7,3)
40143             ELSE
40144               IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
40145               IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
40146               IF(I.GE.13) WID2=WID2*WIDS(7,2)
40147             ENDIF
40148           ELSEIF(I.LE.20) THEN
40149 C...W+/- -> l+/- + nu
40150             FCOF=1D0
40151             IF(KFLR.GT.0) THEN
40152               IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
40153             ELSE
40154               IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
40155             ENDIF
40156           ENDIF
40157           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
40158      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
40159           WDTP(0)=WDTP(0)+WDTP(I)
40160           IF(MDME(IDC,1).GT.0) THEN
40161             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40162             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
40163             WDTE(I,0)=WDTE(I,MDME(IDC,1))
40164             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40165           ENDIF
40166   140   CONTINUE
40167       ENDIF
40168
40169       RETURN
40170       END
40171
40172 C*********************************************************************
40173
40174 C...PYRVSF
40175 C...Calculates R-violating decays of sfermions.
40176 C...  * Only L-violating decays included at this point.
40177
40178       SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
40179
40180 C...Double precision and integer declarations.
40181       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40182       IMPLICIT INTEGER(I-N)
40183 C...Parameter statement to help give large particle numbers.
40184       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40185      &KEXCIT=4000000,KDIMEN=5000000)
40186 C...Commonblocks.
40187       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40188       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40189       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40190      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40191       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40192 C...Local variables.
40193       DOUBLE PRECISION XLAM(0:300), RM2, SM, SMT
40194       INTEGER IDLAM(300,3), KFIN, KFSM, I, J, K, LKNT, ICNT,PYCOMP
40195       SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
40196
40197 C...IS L-VIOLATION ON ?
40198       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40199 C...Mass eigenstate counter
40200         ICNT=INT(KFIN/KSUSY1)
40201 C...SM KF code of SUSY particle
40202         KFSM=KFIN-ICNT*KSUSY1
40203 C...Squared Sparticle Mass
40204         SM=PMAS(PYCOMP(KFIN),1)**2
40205 C... Squared mass of top quark
40206         SMT=PMAS(PYCOMP(6),1)**2
40207 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
40208         IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) THEN
40209           K=INT((KFSM-9)/2)
40210           DO 110 I=1,3
40211             DO 100 J=1,3
40212               IF(I.NE.J) THEN
40213 C...~e,~mu,~tau -> nu_I + lepton-_J
40214                 LKNT = LKNT+1
40215                 IDLAM(LKNT,1)= 12 +2*(I-1)
40216                 IDLAM(LKNT,2)= 11 +2*(J-1)
40217                 IDLAM(LKNT,3)= 0
40218                 XLAM(LKNT)=0D0
40219                 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40220                 IF (IMSS(51).NE.0) XLAM(LKNT) =
40221      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40222 C...KINEMATICS CHECK
40223                 IF (XLAM(LKNT).EQ.0D0) THEN
40224                   LKNT=LKNT-1
40225                 ENDIF
40226               ENDIF
40227   100       CONTINUE
40228   110     CONTINUE
40229 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
40230           J=INT((KFSM-9)/2)
40231           DO 130 I=1,3
40232             IF(I.NE.J) THEN
40233               DO 120 K=1,3
40234                 LKNT = LKNT+1
40235                 IDLAM(LKNT,1)=-12 -2*(I-1)
40236                 IDLAM(LKNT,2)= 11 +2*(K-1)
40237                 IDLAM(LKNT,3)= 0
40238                 XLAM(LKNT)=0D0
40239                 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40240                 IF (IMSS(51).NE.0) XLAM(LKNT) =
40241      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40242 C...KINEMATICS CHECK
40243                 IF (XLAM(LKNT).EQ.0D0) THEN
40244                   LKNT=LKNT-1
40245                 ENDIF
40246   120         CONTINUE
40247             ENDIF
40248   130     CONTINUE
40249 C...~e,~mu,~tau -> u_Jbar + d_K
40250           I=INT((KFSM-9)/2)
40251           DO 150 J=1,3
40252             DO 140 K=1,3
40253               LKNT = LKNT+1
40254               IDLAM(LKNT,1)=-2 -2*(J-1)
40255               IDLAM(LKNT,2)= 1 +2*(K-1)
40256               IDLAM(LKNT,3)= 0
40257               XLAM(LKNT)=0
40258               IF (IMSS(52).NE.0) THEN
40259 C...Use massive top quark
40260                 IF (IDLAM(LKNT,1).EQ.-6) THEN
40261                   RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2
40262      &                 * (SM-SMT)
40263                   XLAM(LKNT) =
40264      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
40265 C...If no top quark, all decay products massless
40266                 ELSE
40267                   RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40268                   XLAM(LKNT) =
40269      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40270                 ENDIF
40271 C...KINEMATICS CHECK
40272                 IF (XLAM(LKNT).EQ.0D0) THEN
40273                   LKNT=LKNT-1
40274                 ENDIF
40275               ENDIF
40276   140       CONTINUE
40277   150     CONTINUE
40278         ENDIF
40279 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
40280 C...No right-handed neutrinos
40281         IF(ICNT.EQ.1) THEN
40282           IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
40283             J=INT((KFSM-10)/2)
40284             DO 170 I=1,3
40285               DO 160 K=1,3
40286                 IF (I.NE.J) THEN
40287 C...~nu_J -> lepton+_I + lepton-_K
40288                   LKNT = LKNT+1
40289                   IDLAM(LKNT,1)=-11 -2*(I-1)
40290                   IDLAM(LKNT,2)= 11 +2*(K-1)
40291                   IDLAM(LKNT,3)=  0
40292                   XLAM(LKNT)=0D0
40293                   RM2=RVLAM(I,J,K)**2 * SM
40294                   IF (IMSS(51).NE.0) XLAM(LKNT) =
40295      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40296 C...KINEMATICS CHECK
40297                   IF (XLAM(LKNT).EQ.0D0) THEN
40298                     LKNT=LKNT-1
40299                   ENDIF
40300                 ENDIF
40301   160         CONTINUE
40302   170       CONTINUE
40303 C...~nu_I -> dbar_J + d_K
40304             I=INT((KFSM-10)/2)
40305             DO 190 J=1,3
40306               DO 180 K=1,3
40307                 LKNT = LKNT+1
40308                 IDLAM(LKNT,1)=-1 -2*(J-1)
40309                 IDLAM(LKNT,2)= 1 +2*(K-1)
40310                 IDLAM(LKNT,3)= 0
40311                 XLAM(LKNT)=0D0
40312                 RM2=3*RVLAMP(I,J,K)**2 * SM
40313                 IF (IMSS(52).NE.0) XLAM(LKNT) =
40314      &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40315 C...KINEMATICS CHECK
40316                 IF (XLAM(LKNT).EQ.0D0) THEN
40317                   LKNT=LKNT-1
40318                 ENDIF
40319   180         CONTINUE
40320   190       CONTINUE
40321           ENDIF
40322         ENDIF
40323 C * SDOWN -> NU(BAR) + D and LEPTON- + U
40324         IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
40325           J=INT((KFSM+1)/2)
40326           DO 210 I=1,3
40327             DO 200 K=1,3
40328 C...~d_J -> nu_Ibar + d_K
40329               LKNT = LKNT+1
40330               IDLAM(LKNT,1)=-12 -2*(I-1)
40331               IDLAM(LKNT,2)=  1 +2*(K-1)
40332               IDLAM(LKNT,3)=  0
40333               XLAM(LKNT)=0D0
40334               RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40335               IF (IMSS(52).NE.0) XLAM(LKNT) =
40336      &             PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40337 C...KINEMATICS CHECK
40338               IF (XLAM(LKNT).EQ.0D0) THEN
40339                 LKNT=LKNT-1
40340               ENDIF
40341   200       CONTINUE
40342   210     CONTINUE
40343           K=INT((KFSM+1)/2)
40344           DO 240 I=1,3
40345             DO 230 J=1,3
40346 C...~d_K -> nu_I + d_J
40347               LKNT = LKNT+1
40348               IDLAM(LKNT,1)= 12 +2*(I-1)
40349               IDLAM(LKNT,2)=  1 +2*(J-1)
40350               IDLAM(LKNT,3)=  0
40351               XLAM(LKNT)=0D0
40352               RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40353               IF (IMSS(52).NE.0) XLAM(LKNT) =
40354      &             PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40355 C...KINEMATICS CHECK
40356               IF (XLAM(LKNT).EQ.0D0) THEN
40357                 LKNT=LKNT-1
40358               ENDIF
40359 C...~d_K -> lepton_I- + u_J
40360   220         LKNT = LKNT+1
40361               IDLAM(LKNT,1)= 11 +2*(I-1)
40362               IDLAM(LKNT,2)=  2 +2*(J-1)
40363               IDLAM(LKNT,3)=  0
40364               XLAM(LKNT)=0D0
40365               IF (IMSS(52).NE.0) THEN
40366 C...Use massive top quark
40367                 IF (IDLAM(LKNT,2).EQ.6) THEN
40368                   RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2*(SM-SMT)
40369                   XLAM(LKNT) =
40370      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
40371 C...If no top quark, all decay products massless
40372                 ELSE
40373                   RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40374                   XLAM(LKNT) =
40375      &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40376                 ENDIF
40377 C...KINEMATICS CHECK
40378                 IF (XLAM(LKNT).EQ.0D0) THEN
40379                   LKNT=LKNT-1
40380                 ENDIF
40381               ENDIF
40382   230       CONTINUE
40383   240     CONTINUE
40384         ENDIF
40385 C * SUP -> LEPTON+ + D
40386         IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
40387           J=INT((KFSM+1)/2)
40388           DO 260 I=1,3
40389             DO 250 K=1,3
40390 C...~u_J -> lepton_I+ + d_K
40391               LKNT = LKNT+1
40392               IDLAM(LKNT,1)=-11 -2*(I-1)
40393               IDLAM(LKNT,2)=  1 +2*(K-1)
40394               IDLAM(LKNT,3)=  0
40395               XLAM(LKNT)=0D0
40396               RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40397               IF (IMSS(52).NE.0) XLAM(LKNT) =
40398      &             PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40399 C...KINEMATICS CHECK
40400               IF (XLAM(LKNT).EQ.0D0) THEN
40401                 LKNT=LKNT-1
40402               ENDIF
40403   250       CONTINUE
40404   260     CONTINUE
40405         ENDIF
40406       ENDIF
40407
40408       RETURN
40409       END
40410
40411 C*********************************************************************
40412
40413 C...PYRVNE
40414 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
40415 C...  * Only L-violating decays included at this point.
40416
40417       SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
40418
40419 C...Double precision and integer declarations.
40420       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40421       IMPLICIT INTEGER(I-N)
40422 C...Parameter statement to help give large particle numbers.
40423       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40424      &KEXCIT=4000000,KDIMEN=5000000)
40425 C...Commonblocks.
40426       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40427       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40428       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40429       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40430      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40431       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40432 C...Local parameters
40433       PARAMETER (UNB=80)
40434 C...Local variables.
40435       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40436       DOUBLE PRECISION XLAM(0:300),AB,RES,RMS
40437       DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), LAMC, RMQ(6)
40438       INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP,ISM,IDR,IDR2
40439       LOGICAL DCMASS
40440       CHARACTER*31 PRC
40441       CHARACTER*11 FNAME
40442       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40443
40444 C...LEPTON NUMBER VIOLATING DECAYS
40445       IF (((IMSS(51).GE.1).OR.(IMSS(52).GE.1))) THEN
40446         KFSM=KFIN-KSUSY1
40447         IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
40448 C...WHICH NEUTRALINO ?
40449           NCHI=1
40450           IF (KFSM.EQ.23) NCHI=2
40451           IF (KFSM.EQ.25) NCHI=3
40452           IF (KFSM.EQ.35) NCHI=4
40453 C...SIGN OF MASS
40454           ISM=1
40455           IF (SMZ(NCHI).LT.0D0) ISM=-ISM
40456
40457 C...Useful parameters for the calculation of the A and B constants.
40458           WMASS = PMAS(PYCOMP(24),1)
40459           ECHG = 2*SQRT(PARU(103)*PARU(1))
40460           COSB=1/(SQRT(1+RMSS(5)**2))
40461           SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
40462           COSW=SQRT(1-PARU(102))
40463           SINW=SQRT(PARU(102))
40464           GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
40465 C...Run quark masses to neutralino mass squared (for Higgs-type
40466 C...couplings)
40467           SQMCHI=PMAS(PYCOMP(KFIN),1)**2
40468           DO 100 I=1,6
40469             RMQ(I)=PYMRUN(I,SQMCHI)
40470   100     CONTINUE
40471
40472 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
40473           DO 110 I = 1,4
40474             ZPMIX(I,1)= ZMIX(I,1)*COSW+ZMIX(I,2)*SINW
40475             ZPMIX(I,2)=-ZMIX(I,1)*SINW+ZMIX(I,2)*COSW
40476             ZPMIX(I,3)= ZMIX(I,3)
40477             ZPMIX(I,4)= ZMIX(I,4)
40478   110     CONTINUE
40479
40480           C1=GW*ZMIX(NCHI,3)/(2.*COSB*WMASS)
40481           C1U=GW*ZMIX(NCHI,4)/(2.*SINB*WMASS)
40482           C2=ECHG*ZPMIX(NCHI,1)
40483           C3=GW*ZPMIX(NCHI,2)/COSW
40484           EU=2D0/3D0
40485           ED=-1D0/3D0
40486 C... AB(x,y,z):
40487 C       x=1-2  : Select A or B constant     (1:A ; 2:B)
40488 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40489 C                                    11-16:e,nu_e,mu,...)
40490 C       z=1-2  : Mass eigenstate number
40491 C...CALCULATE COUPLINGS
40492           DO 120 I = 11,15,2
40493             CMS=PMAS(PYCOMP(I),1)
40494             AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) - SFMIX(I,3)
40495      &           *(C2-C3*SINW**2))
40496             AB(1,I,2)=ISM*(-CMS*C1*SFMIX(I,2) + SFMIX(I,4)
40497      &           *(C2-C3*SINW**2))
40498             AB(2,I,1)= -CMS*C1*SFMIX(I,3) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
40499      &           **2))
40500             AB(2,I,2)=CMS*C1*SFMIX(I,4) + SFMIX(I,2)*(C2+C3*(5D-1 - SINW
40501      &           **2))
40502             AB(1,I+1,1)=0D0
40503             AB(2,I+1,1)=5D-1*C3
40504             AB(1,I+1,2)=0D0
40505             AB(2,I+1,2)=0D0
40506             J=I-10
40507             CMS=RMQ(J)
40508             AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) + SFMIX(J,3)
40509      &           *ED*(C2-ED*C3*SINW**2))
40510             AB(1,J,2)=ISM*(-CMS*C1*SFMIX(J,2) - SFMIX(J,4)
40511      &           *ED*(C2-ED*C3*SINW**2))
40512             AB(2,J,1)=-CMS*C1*SFMIX(J,3) + SFMIX(J,1)
40513      &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40514             AB(2,J,2)=CMS*C1*SFMIX(J,4) - SFMIX(J,2)
40515      &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40516             J=J+1
40517             CMS=RMQ(J)
40518             AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) + SFMIX(J,3)
40519      &           *EU*(C2-C3*SINW**2))
40520             AB(1,J,2)=ISM*(-CMS*C1U*SFMIX(J,2) - SFMIX(J,4)
40521      &           *EU*(C2-C3*SINW**2))
40522             AB(2,J,1)=-CMS*C1U*SFMIX(J,3) + SFMIX(J,1)
40523      &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40524             AB(2,J,2)=CMS*C1U*SFMIX(J,4) - SFMIX(J,2)
40525      &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40526   120     CONTINUE
40527
40528 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
40529 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
40530 C...STEP IN I,J,K USING SINGLE COUNTER
40531           DO 140 ISC=0,26
40532 C...LAMBDA COUPLING ASYM IN I,J
40533             IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40534               LKNT = LKNT+1
40535               IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40536               IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40537               IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40538               XLAM(LKNT)=0D0
40539               IF(IMSS(51).EQ.0) GOTO 130
40540 C...Set coupling, and decay product masses on/off
40541               LAMC=RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40542               DCMASS=.FALSE.
40543 C...Resonance KF codes (1=I,2=J,3=K)
40544               KFR(1)=-IDLAM(LKNT,1)
40545               KFR(2)=-IDLAM(LKNT,2)
40546               KFR(3)=-IDLAM(LKNT,3)
40547 C...Calculate width.
40548               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40549      &             ,XLAM(LKNT))
40550               XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40551 C...Charge conjugate mode.
40552   130         LKNT=LKNT+1
40553               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40554               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40555               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40556               XLAM(LKNT)=XLAM(LKNT-1)
40557 C...KINEMATICS CHECK
40558               IF (XLAM(LKNT).EQ.0D0) THEN
40559                 LKNT=LKNT-2
40560               ENDIF
40561             ENDIF
40562   140     CONTINUE
40563
40564 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
40565 C * CHI0 -> NUBAR_I + DBAR_J + D_K
40566           DO 170 ISC=0,26
40567             LKNT = LKNT+1
40568             IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40569             IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40570             IDLAM(LKNT,3)=  1 +2*MOD(ISC,3)
40571             XLAM(LKNT)=0D0
40572             IF(IMSS(52).EQ.0) GOTO 150
40573 C...Set coupling, and decay product masses on/off
40574             LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40575             DCMASS=.FALSE.
40576 C...Resonance KF codes (1=I,2=J,3=K)
40577             KFR(1)=-IDLAM(LKNT,1)
40578             KFR(2)=-IDLAM(LKNT,2)
40579             KFR(3)=-IDLAM(LKNT,3)
40580 C...Calculate width.
40581             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40582      &           ,XLAM(LKNT))
40583             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40584 C...Charge conjugate mode.
40585   150       LKNT=LKNT+1
40586             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40587             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40588             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40589             XLAM(LKNT)=XLAM(LKNT-1)
40590 C...KINEMATICS CHECK
40591             IF (XLAM(LKNT).EQ.0D0) THEN
40592               LKNT=LKNT-2
40593             ENDIF
40594
40595 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
40596             LKNT = LKNT+1
40597             IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40598             IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40599             IDLAM(LKNT,3)=  1 +2*MOD(ISC,3)
40600             XLAM(LKNT)=0D0
40601             IF(IMSS(52).EQ.0) GOTO 160
40602 C...Set coupling, and decay product masses on/off
40603             LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40604             DCMASS=.FALSE.
40605             IF (IDLAM(LKNT,2).EQ.-6) DCMASS=.TRUE.
40606 C...Resonance KF codes (1=I,2=J,3=K)
40607             KFR(1)=-IDLAM(LKNT,1)
40608             KFR(2)=-IDLAM(LKNT,2)
40609             KFR(3)=-IDLAM(LKNT,3)
40610 C...Calculate width.
40611             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40612      &           ,XLAM(LKNT))
40613             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40614 C...Charge conjugate mode.
40615   160       LKNT=LKNT+1
40616             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40617             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40618             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40619             XLAM(LKNT)=XLAM(LKNT-1)
40620 C...KINEMATICS CHECK
40621             IF (XLAM(LKNT).EQ.0D0) THEN
40622               LKNT=LKNT-2
40623             ENDIF
40624   170     CONTINUE
40625
40626         ENDIF
40627       ENDIF
40628
40629       RETURN
40630       END
40631
40632 C*********************************************************************
40633
40634 C...PYRVCH
40635 C...Calculates R-violating chargino decay widths.
40636 C...  * Only L-violating decays included at this point.
40637
40638       SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
40639
40640 C...Double precision and integer declarations.
40641       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40642       IMPLICIT INTEGER(I-N)
40643 C...Parameter statement to help give large particle numbers.
40644       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40645      &KEXCIT=4000000,KDIMEN=5000000)
40646 C...Commonblocks.
40647       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40648       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40649       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40650       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40651      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40652       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40653 C...Local variables.
40654       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40655       DOUBLE PRECISION XLAM(0:300),AB, RES, RMS, C1U, C1V, C2, C3
40656       DOUBLE PRECISION LAMC, RMQ(6)
40657       INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP
40658       LOGICAL DCMASS
40659       CHARACTER*31 PRC
40660       CHARACTER*10 FNAME
40661       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40662
40663 C...LEPTON NUMBER VIOLATING DECAYS
40664       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40665         KFSM=KFIN-KSUSY1
40666         IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
40667           ISM  = 1
40668 C...WHICH CHARGINO ?
40669           NCHI = 1
40670           IF (KFSM.EQ.37) NCHI = 2
40671
40672 C...Useful parameters for calculating the A and B constants.
40673           IF (SMW(NCHI).LT.0D0) ISM=-1
40674           WMASS   = PMAS(PYCOMP(24),1)
40675           COSB    = 1/(SQRT(1+RMSS(5)**2))
40676           SINB    = RMSS(5)/SQRT(1+RMSS(5)**2)
40677           GW2     = 4*PARU(103)*PARU(1)/PARU(102)
40678           SQMCHI  = PMAS(PYCOMP(KFSM),1)**2
40679 C...Running masses at Q^2=MCHI^2.
40680           DO 100 I=1,6
40681             RMQ(I)=PYMRUN(I,SQMCHI)
40682   100     CONTINUE
40683
40684 C...Signs chosen to agree with U & V convention used in hep-ph/9912407.
40685           C1U     = -UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
40686           C1V     = -VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
40687           C2      = -UMIX(NCHI,1)
40688           C3      = -VMIX(NCHI,1)
40689 C... AB(x,y,z):
40690 C       x=1-2  : A or B coefficient  (1:A ; 2:B)
40691 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40692 C                                    11-16:e,nu_e,mu,...)
40693 C       z=1-2  : Mass eigenstate number
40694           DO 110 I = 11,15,2
40695             AB(1,I,1)   = 0D0
40696             AB(1,I,2)   = 0D0
40697             AB(2,I,1)   = PMAS(PYCOMP(I),1)*C1U*SFMIX(I,3) +
40698      &           SFMIX(I,1)*C2
40699             AB(2,I,2)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) -
40700      &           SFMIX(I,2)*C2
40701             AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
40702             AB(1,I+1,2) = 0D0
40703             AB(2,I+1,1) = ISM*C3
40704             AB(2,I+1,2) = 0D0
40705             J=I-10
40706             AB(1,J,1)   = -RMQ(J+1)*C1V*SFMIX(J,1)
40707             AB(1,J,2)   = RMQ(J+1)*C1V*SFMIX(J,2)
40708             AB(2,J,1)   = ISM*(RMQ(J)*C1U*SFMIX(J,3) + SFMIX(J,1)*C2)
40709             AB(2,J,2)   = -ISM*(RMQ(J)*C1U*SFMIX(J,4) + SFMIX(J,2)*C2)
40710             J=J+1
40711             AB(1,J,1)   = -RMQ(J-1)*C1U*SFMIX(J,1)
40712             AB(1,J,2)   = RMQ(J-1)*C1U*SFMIX(J,2)
40713             AB(2,J,1)   = ISM*(RMQ(J)*C1V*SFMIX(J,3) - SFMIX(J,1)*C3)
40714             AB(2,J,2)   = -ISM*(RMQ(J)*C1V*SFMIX(J,4) + SFMIX(J,2)*C3)
40715   110     CONTINUE
40716
40717 C...LOOP OVER DECAY MODES
40718           DO 140 ISC=0,26
40719
40720 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
40721             IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40722               LKNT = LKNT+1
40723               IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
40724               IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
40725               IDLAM(LKNT,3) =  12 +2*MOD(ISC,3)
40726               XLAM(LKNT)=0D0
40727               IF(IMSS(51).EQ.0) GOTO 120
40728 C...Set coupling, and decay product masses on/off
40729               LAMC = GW2 *
40730      &             RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40731               DCMASS=.FALSE.
40732 C...Resonance KF codes (1=I,2=J,3=K).
40733               KFR(1) = 0
40734               KFR(2) = 0
40735               KFR(3) = -IDLAM(LKNT,3)+1
40736 C...Calculate width.
40737               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40738      &             ,XLAM(LKNT))
40739               XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40740 C...KINEMATICS CHECK
40741               IF (XLAM(LKNT).EQ.0D0) THEN
40742                 LKNT=LKNT-1
40743               ENDIF
40744
40745 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
40746   120         IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
40747                 LKNT = LKNT+1
40748                 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40749                 IDLAM(LKNT,2)= 12 +2*MOD(ISC/3,3)
40750                 IDLAM(LKNT,3)=-11 -2*MOD(ISC,3)
40751                 XLAM(LKNT)=0D0
40752                 IF(IMSS(51).EQ.0) GOTO 130
40753 C...Set coupling, and decay product masses on/off
40754                 LAMC = GW2 *
40755      &              RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40756 C...I,J SYMMETRY => FACTOR 2
40757                 LAMC=2*LAMC
40758                 DCMASS=.FALSE.
40759 C...Resonance KF codes (1=I,2=J,3=K)
40760                 KFR(1)=IDLAM(LKNT,1)-1
40761                 KFR(2)=IDLAM(LKNT,2)-1
40762                 KFR(3)=0
40763 C...Calculate width.
40764                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
40765      &               IDLAM(LKNT,3),XLAM(LKNT))
40766                 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40767 C...KINEMATICS CHECK
40768                 IF (XLAM(LKNT).EQ.0D0) THEN
40769                   LKNT=LKNT-1
40770                 ENDIF
40771   130         ENDIF
40772
40773 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
40774               LKNT = LKNT+1
40775               IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40776               IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40777               IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40778               XLAM(LKNT)=0D0
40779               IF(IMSS(51).EQ.0) GOTO 140
40780 C...Set coupling, and decay product masses on/off
40781               LAMC = GW2 *
40782      &             RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40783 C...I,J SYMMETRY => FACTOR 2
40784               LAMC=2*LAMC
40785               DCMASS=.FALSE.
40786 C...Resonance KF codes (1=I,2=J,3=K)
40787               KFR(1)=-IDLAM(LKNT,1)+1
40788               KFR(2)=-IDLAM(LKNT,2)+1
40789               KFR(3)=0
40790 C...Calculate width.
40791               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40792      &             ,XLAM(LKNT))
40793               XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40794 C...KINEMATICS CHECK
40795               IF (XLAM(LKNT).EQ.0D0) THEN
40796                 LKNT=LKNT-1
40797               ENDIF
40798             ENDIF
40799   140     CONTINUE
40800
40801 C...LQD TYPE R-VIOLATION
40802 C...LOOP OVER DECAY MODES
40803           DO 180 ISC=0,26
40804
40805 C...CHI+ -> NUBAR_I + DBAR_J + U_K
40806             LKNT = LKNT+1
40807             IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40808             IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40809             IDLAM(LKNT,3)=  2 +2*MOD(ISC,3)
40810             XLAM(LKNT)=0D0
40811             IF(IMSS(52).EQ.0) GOTO 150
40812 C...Set coupling, and decay product masses on/off
40813             LAMC = 3 * GW2 *
40814      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40815             DCMASS=.FALSE.
40816             IF (IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40817 C...Resonance KF codes (1=I,2=J,3=K)
40818             KFR(1)=0
40819             KFR(2)=0
40820             KFR(3)=-IDLAM(LKNT,3)+1
40821 C...Calculate width.
40822             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40823      &           ,XLAM(LKNT))
40824             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40825 C...KINEMATICS CHECK
40826             IF (XLAM(LKNT).EQ.0D0) THEN
40827               LKNT=LKNT-1
40828             ENDIF
40829
40830 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
40831   150       LKNT = LKNT+1
40832             IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40833             IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40834             IDLAM(LKNT,3)=  2 +2*MOD(ISC,3)
40835             XLAM(LKNT)=0D0
40836             IF(IMSS(52).EQ.0) GOTO 160
40837 C...Set coupling, and decay product masses on/off
40838             LAMC = 3 * GW2 *
40839      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40840             DCMASS=.FALSE.
40841             IF (-IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40842 C...Resonance KF codes (1=I,2=J,3=K)
40843             KFR(1)=0
40844             KFR(2)=0
40845             KFR(3)=-IDLAM(LKNT,3)+1
40846 C...Calculate width.
40847             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40848      &           ,XLAM(LKNT))
40849             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40850 C...KINEMATICS CHECK
40851             IF (XLAM(LKNT).EQ.0D0) THEN
40852               LKNT=LKNT-1
40853             ENDIF
40854
40855 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
40856   160       LKNT = LKNT+1
40857             IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40858             IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40859             IDLAM(LKNT,3)=  1 +2*MOD(ISC,3)
40860             XLAM(LKNT)=0D0
40861             IF(IMSS(52).EQ.0) GOTO 170
40862 C...Set coupling, and decay product masses on/off
40863             LAMC = 3 * GW2 *
40864      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40865             DCMASS=.FALSE.
40866 C...Resonance KF codes (1=I,2=J,3=K)
40867             KFR(1)=-IDLAM(LKNT,1)+1
40868             KFR(2)=-IDLAM(LKNT,2)+1
40869             KFR(3)=0
40870 C...Calculate width.
40871             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40872      &           ,XLAM(LKNT))
40873             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40874 C...KINEMATICS CHECK
40875             IF (XLAM(LKNT).EQ.0D0) THEN
40876               LKNT=LKNT-1
40877             ENDIF
40878
40879 C * CHI+ -> NU_I + U_J + DBAR_K.
40880   170       LKNT = LKNT+1
40881             IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40882             IDLAM(LKNT,2)=  2 +2*MOD(ISC/3,3)
40883             IDLAM(LKNT,3)= -1 -2*MOD(ISC,3)
40884             XLAM(LKNT)=0D0
40885             IF(IMSS(52).EQ.0) GOTO 180
40886 C...Set coupling, and decay product masses on/off
40887             DCMASS=.FALSE.
40888             LAMC = 3 * GW2 *
40889      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40890             IF (IDLAM(LKNT,2).EQ.6) DCMASS=.TRUE.
40891 C...Resonance KF codes (1=I,2=J,3=K)
40892             KFR(1)=-IDLAM(LKNT,1)+1
40893             KFR(2)=-IDLAM(LKNT,2)+1
40894             KFR(3)=0
40895 C...Calculate width.
40896             CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40897      &           ,XLAM(LKNT))
40898             XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40899 C...KINEMATICS CHECK
40900             IF (XLAM(LKNT).EQ.0D0) THEN
40901               LKNT=LKNT-1
40902             ENDIF
40903
40904   180     CONTINUE
40905         ENDIF
40906       ENDIF
40907
40908       RETURN
40909       END
40910
40911 C*********************************************************************
40912
40913 C...PYRVSB
40914 C...Auxiliary function to PYRVSF for calculating R-Violating
40915 C...sfermion widths. Though the decay products are most often treated
40916 C...as massless in the calculation, the kinematical boundary of phase
40917 C...space is tested using the true masses.
40918 C...MODE = 1: All decay products massive
40919 C...MODE = 2: Decay product 1 massless
40920 C...MODE = 3: Decay product 2 massless
40921 C...MODE = 4: All decay products  massless
40922
40923       FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
40924
40925       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40926       IMPLICIT INTEGER (I-N)
40927       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40928       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40929       SAVE /PYDAT1/,/PYDAT2/
40930       DOUBLE PRECISION SM(3), PYRVSB, RM2
40931       CHARACTER*24 PRC
40932       INTEGER KFIN, ID1,ID2, PYCOMP, KC(3), MODE
40933       KC(1)=PYCOMP(KFIN)
40934       KC(2)=PYCOMP(ID1)
40935       KC(3)=PYCOMP(ID2)
40936       SM(1)=PMAS(KC(1),1)**2
40937       SM(2)=PMAS(KC(2),1)**2
40938       SM(3)=PMAS(KC(3),1)**2
40939 C...Kinematics check
40940       IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
40941         PYRVSB=0D0
40942         RETURN
40943       ENDIF
40944 C...CM momenta squared
40945       IF (MODE.EQ.1) THEN
40946         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
40947      &       * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
40948       ELSE IF (MODE.EQ.2) THEN
40949         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
40950       ELSE IF (MODE.EQ.3) THEN
40951         P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
40952       ELSE
40953         P2CM=SM(1)/4.
40954       ENDIF
40955 C...Calculate Width
40956       PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
40957
40958       RETURN
40959       END
40960
40961 C*********************************************************************
40962
40963 C...PYRVGW
40964 C...Main routine for R-Violating neutralino/chargino 3-body widths.
40965
40966       SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
40967
40968       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40969       IMPLICIT INTEGER (I-N)
40970       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40971      &KEXCIT=4000000,KDIMEN=5000000)
40972       PARAMETER (EPS=1D-2)
40973       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40974       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40975       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40976      & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40977       DOUBLE PRECISION RMS, XLIM(3,3), RES, XLAM, XLAM0, PREF
40978       INTEGER INTC, KC(0:3), KFIN,ID1,ID2,ID3,KFR,PYCOMP
40979       CHARACTER*31 PRC
40980       LOGICAL DCMASS, DCHECK(6)
40981       SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
40982
40983       KC(0)=PYCOMP(KFIN)
40984       KC(1)=PYCOMP(ID1)
40985       KC(2)=PYCOMP(ID2)
40986       KC(3)=PYCOMP(ID3)
40987       DO 100 INTC=0,3
40988         RMS(INTC)=PMAS(KC(INTC),1)
40989   100 CONTINUE
40990
40991 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
40992       XLIM(1,1)=(RMS(1)+RMS(2))**2
40993       XLIM(1,2)=(RMS(0)-RMS(3))**2
40994       XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
40995       XLIM(2,1)=(RMS(2)+RMS(3))**2
40996       XLIM(2,2)=(RMS(0)-RMS(1))**2
40997       XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
40998       XLIM(3,1)=(RMS(1)+RMS(3))**2
40999       XLIM(3,2)=(RMS(0)-RMS(2))**2
41000       XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
41001       IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
41002         RETURN
41003       ENDIF
41004
41005 C...INITIALIZE RESONANCE INFORMATION
41006       DO 120 JRES=1,3
41007         DO 110 IMASS=1,2
41008           IRES=2*(JRES-1)+IMASS
41009           RES(IRES,1)=0D0
41010           DCHECK(IRES)=.FALSE.
41011 C...NO RIGHT-HANDED NEUTRINOS
41012           IF((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR.(IABS(KFR(JRES
41013      &         )).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))) GOTO 110
41014           RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
41015           RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
41016           RES(IRES,3) = IABS(KFR(JRES))
41017           RES(IRES,4) = IMASS
41018           IF (KFR(JRES).LT.0) RES(IRES,5) = 1D0
41019           IF (KFR(JRES).GT.0) RES(IRES,5) = 0D0
41020   110   CONTINUE
41021   120 CONTINUE
41022
41023 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
41024
41025 C...RESONANCE CONTRIBUTIONS
41026 C...(Only sum contributions where the resonance is off shell).
41027 C...LOOP OVER MASS STATES
41028       DO 130 J=1,2
41029         IDR=J
41030         IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
41031      &       +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41032      &       .AND.RES(IDR,1).NE.0D0) THEN
41033           DCHECK(IDR) =.TRUE.
41034           XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(2,3,1)
41035         ENDIF
41036
41037         IDR=J+2
41038         IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41039      &       +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41040      &       .AND.RES(IDR,1).NE.0D0) THEN
41041           DCHECK(IDR) =.TRUE.
41042           XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(1,3,2)
41043         ENDIF
41044
41045         IDR=J+4
41046         IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41047      &       +RMS(2)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),2+J)).GT.EPS
41048      &       .AND.RES(IDR,1).NE.0D0) THEN
41049           DCHECK(IDR) =.TRUE.
41050           XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),2+J)**2 * PYRVI1(1,2,3)
41051         ENDIF
41052   130 CONTINUE
41053
41054 C... L-R INTERFERENCES
41055 C... (Only add contributions where both contributing diagrams
41056 C... are non-resonant).
41057       IDR=1
41058       IF (DCHECK(1).AND.DCHECK(2)) THEN
41059         XLAM  = XLAM + PYRVI2(2,1,3)
41060      &     * SFMIX(NINT(RES(1,3)),1+2*NINT(RES(1,5)))
41061      &     * SFMIX(NINT(RES(2,3)),2+2*NINT(RES(2,5)))
41062       ENDIF
41063
41064       IDR=3
41065       IF (DCHECK(3).AND.DCHECK(4)) THEN
41066         XLAM  = XLAM + PYRVI2(1,3,2)
41067      &     * SFMIX(NINT(RES(3,3)),1+2*NINT(RES(3,5)))
41068      &     * SFMIX(NINT(RES(4,3)),2+2*NINT(RES(4,5)))
41069       ENDIF
41070
41071       IDR=5
41072       IF (DCHECK(5).AND.DCHECK(6)) THEN
41073         XLAM  = XLAM + PYRVI2(1,2,3)
41074      &     * SFMIX(NINT(RES(5,3)),1+2*NINT(RES(5,5)))
41075      &     * SFMIX(NINT(RES(6,3)),2+2*NINT(RES(6,5)))
41076       ENDIF
41077
41078 C... TRUE INTERFERENCES
41079 C... (Only add contributions where both contributing diagrams
41080 C... are non-resonant).
41081       PREF=-2.
41082       IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2.
41083       DO 150 IKR1 = 1,2
41084         DO 140 IKR2 = 1,2
41085           IDR  = IKR1+2
41086           IDR2 = IKR2
41087           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41088             XLAM = XLAM + PREF*PYRVI3(1,3,2) *
41089      &      SFMIX(NINT(RES(IDR,3)),IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41090           ENDIF
41091
41092           IDR  = IKR1+4
41093           IDR2 = IKR2
41094           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41095             XLAM = XLAM + PREF*PYRVI3(1,2,3) *
41096      &      SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41097           ENDIF
41098
41099           IDR  = IKR1+4
41100           IDR2 = IKR2+2
41101           IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41102             XLAM = XLAM + PREF*PYRVI3(2,1,3) *
41103      &      SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41104           ENDIF
41105   140   CONTINUE
41106   150 CONTINUE
41107       RETURN
41108       END
41109
41110 C*********************************************************************
41111
41112 C...PYRVI1
41113 C...Function to integrate resonance contributions
41114
41115       FUNCTION PYRVI1(ID1,ID2,ID3)
41116
41117       IMPLICIT NONE
41118       DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
41119       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41120       INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41121       LOGICAL MFLAG,DCMASS
41122       EXTERNAL PYRVG1,PYGAUS
41123       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41124       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41125       SAVE/PYRVNV/,/PYRVPM/
41126 C...Initialize mass and width information
41127       PYRVI1=0D0
41128       RM(0)=RMS(0)
41129       RM(1)=RMS(ID1)
41130       RM(2)=RMS(ID2)
41131       RM(3)=RMS(ID3)
41132       RESM(1)=RES(IDR,1)
41133       RESW(1)=RES(IDR,2)
41134 C...A->B and B->A for antisparticles
41135       IANTI=NINT(RES(IDR,5))
41136       A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41137       B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41138 C...Integration boundaries and mass flag
41139       LO=(RM(1)+RM(2))**2
41140       HI=(RM(0)-RM(3))**2
41141       MFLAG=DCMASS
41142       PYRVI1=PYGAUS(PYRVG1,LO,HI,1D-2)
41143       RETURN
41144       END
41145
41146 C*********************************************************************
41147
41148 C...PYRVI2
41149 C...Function to integrate L-R interference contributions
41150
41151       FUNCTION PYRVI2(ID1,ID2,ID3)
41152
41153       IMPLICIT NONE
41154       DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
41155       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41156       INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41157       LOGICAL MFLAG,DCMASS
41158       EXTERNAL PYRVG2,PYGAUS
41159       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41160       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41161       SAVE/PYRVNV/,/PYRVPM/
41162 C...Initialize mass and width information
41163       PYRVI2=0D0
41164       RM(0)=RMS(0)
41165       RM(1)=RMS(ID1)
41166       RM(2)=RMS(ID2)
41167       RM(3)=RMS(ID3)
41168       RESM(1)=RES(IDR,1)
41169       RESW(1)=RES(IDR,2)
41170       RESM(2)=RES(IDR+1,1)
41171       RESW(2)=RES(IDR+1,2)
41172 C...A->B and B->A for antisparticles
41173       IANTI=NINT(RES(IDR,5))
41174       A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41175       B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41176       A(2)=AB(1+IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41177       B(2)=AB(2-IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41178 C...Boundaries and mass flag
41179       LO=(RM(1)+RM(2))**2
41180       HI=(RM(0)-RM(3))**2
41181       MFLAG=DCMASS
41182       PYRVI2=PYGAUS(PYRVG2,LO,HI,1D-2)
41183       RETURN
41184       END
41185
41186 C*********************************************************************
41187
41188 C...PYRVI3
41189 C...Function to integrate true interference contributions
41190
41191       FUNCTION PYRVI3(ID1,ID2,ID3)
41192
41193       IMPLICIT NONE
41194       DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
41195       DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41196       INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41197       LOGICAL MFLAG,DCMASS
41198       EXTERNAL PYRVG3,PYGAUS
41199       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41200       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41201       SAVE/PYRVNV/,/PYRVPM/
41202 C...Initialize mass and width information
41203       PYRVI3=0D0
41204       RM(0)=RMS(0)
41205       RM(1)=RMS(ID1)
41206       RM(2)=RMS(ID2)
41207       RM(3)=RMS(ID3)
41208       RESM(1)=RES(IDR,1)
41209       RESW(1)=RES(IDR,2)
41210       RESM(2)=RES(IDR2,1)
41211       RESW(2)=RES(IDR2,2)
41212 C...A -> B and B -> A for antisparticles
41213       IANTI=NINT(RES(IDR,5))
41214       A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41215       B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41216       IANTI=NINT(RES(IDR2,5))
41217       A(2)=AB(1+IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41218       B(2)=AB(2-IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41219 C...Boundaries and mass flag
41220       LO=(RM(1)+RM(2))**2
41221       HI=(RM(0)-RM(3))**2
41222       MFLAG=DCMASS
41223       PYRVI3=PYGAUS(PYRVG3,LO,HI,1D-2)
41224       RETURN
41225       END
41226
41227 C*********************************************************************
41228
41229 C...PYRVG1
41230 C...Integrand for resonance contributions
41231
41232       FUNCTION PYRVG1(X)
41233
41234       IMPLICIT NONE
41235       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41236       DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVR
41237       DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SQ1,SR1,SR2,A1,A2
41238       LOGICAL MFLAG
41239       SAVE/PYRVPM/
41240       RVR=PYRVR(X,RESM(1),RESW(1))
41241       C1=2D0*SQRT(MAX(0D0,X))
41242       IF (.NOT.MFLAG) THEN
41243         E2=X/C1
41244         E3=(RM(0)**2-X)/C1
41245         DELTAY=4D0*E2*E3
41246         PYRVG1=DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
41247       ELSE
41248         E2=(X-RM(1)**2+RM(2)**2)/C1
41249         E3=(RM(0)**2-X-RM(3)**2)/C1
41250         SQ1=(E2+E3)**2
41251         SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41252         SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41253         YMIN=SQ1-(SR1+SR2)**2
41254         YMAX=SQ1-(SR1-SR2)**2
41255         DELTAY=YMAX-YMIN
41256         A1=4*A(1)*B(1)*RM(3)*RM(0)
41257         A2=(A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
41258         PYRVG1=DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
41259       ENDIF
41260       RETURN
41261       END
41262
41263 C*********************************************************************
41264
41265 C...PYRVG2
41266 C...Integrand for L-R interference contributions
41267
41268       FUNCTION PYRVG2(X)
41269
41270       IMPLICIT NONE
41271       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41272       DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVS
41273       DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SQ1,SR1,SR2
41274       LOGICAL MFLAG
41275       SAVE/PYRVPM/
41276       C1=2D0*SQRT(MAX(0D0,X))
41277       RVS=PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
41278       IF (.NOT.MFLAG) THEN
41279         E2=X/C1
41280         E3=(RM(0)**2-X)/C1
41281         DELTAY=4D0*E2*E3
41282         PYRVG2=DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
41283       ELSE
41284         E2=(X-RM(1)**2+RM(2)**2)/C1
41285         E3=(RM(0)**2-X-RM(3)**2)/C1
41286         SQ1=(E2+E3)**2
41287         SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41288         SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41289         YMIN=SQ1-(SR1+SR2)**2
41290         YMAX=SQ1-(SR1-SR2)**2
41291         DELTAY=YMAX-YMIN
41292         PYRVG2=DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
41293      &       + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
41294      &       + 2*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
41295       ENDIF
41296       RETURN
41297       END
41298
41299 C*********************************************************************
41300
41301 C...PYRVG3
41302 C...Function to do Y integration over true interference contributions
41303
41304       FUNCTION PYRVG3(X)
41305
41306       IMPLICIT NONE
41307       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41308 C...Second Dalitz variable for PYRVG4
41309       COMMON/PYG2DX/X1
41310       DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
41311       DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
41312       DOUBLE PRECISION PYRVG3, PYRVG4, PYGAUS
41313       LOGICAL MFLAG
41314       EXTERNAL PYGAUS,PYRVG4
41315       SAVE/PYRVPM/,/PYG2DX/
41316       C1=2D0*SQRT(MAX(0D0,X))
41317       X1=X
41318       IF (.NOT.MFLAG) THEN
41319         E2=X/C1
41320         E3=(RM(0)**2-X)/C1
41321         YMIN=0D0
41322         YMAX=4D0*E2*E3
41323       ELSE
41324         E2=(X-RM(1)**2+RM(2)**2)/C1
41325         E3=(RM(0)**2-X-RM(3)**2)/C1
41326         SQ1=(E2+E3)**2
41327         SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41328         SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41329         YMIN=SQ1-(SR1+SR2)**2
41330         YMAX=SQ1-(SR1-SR2)**2
41331       ENDIF
41332       PYRVG3=PYGAUS(PYRVG4,YMIN,YMAX,1D-2)
41333       RETURN
41334       END
41335
41336 C*********************************************************************
41337
41338 C...PYRVG4
41339 C...Integrand for true intereference contributions
41340
41341       FUNCTION PYRVG4(Y)
41342
41343       IMPLICIT NONE
41344       COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41345       COMMON/PYG2DX/X
41346       DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
41347       LOGICAL MFLAG
41348       SAVE /PYRVPM/,/PYG2DX/
41349       PYRVG4=0D0
41350       RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
41351       IF (.NOT.MFLAG) THEN
41352         PYRVG4=RVS*B(1)*B(2)*X*Y
41353       ELSE
41354         PYRVG4=RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
41355      &       + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
41356      &       + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
41357      &       + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
41358       ENDIF
41359       RETURN
41360       END
41361
41362 C*********************************************************************
41363
41364 C...PYRVR
41365 C...Breit-Wigner for resonance contributions
41366
41367       FUNCTION PYRVR(Mab2,RM,RW)
41368
41369       IMPLICIT NONE
41370       DOUBLE PRECISION Mab2,RM,RW,PYRVR
41371       PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
41372       RETURN
41373       END
41374
41375 C*********************************************************************
41376
41377 C...PYRVS
41378 C...Interference function
41379
41380       FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
41381
41382       IMPLICIT NONE
41383       DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
41384       PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
41385      &     +W1*W2*M1*M2)
41386       RETURN
41387       END
41388
41389 C*********************************************************************
41390
41391 C...PY1ENT
41392 C...Stores one parton/particle in commonblock PYJETS.
41393
41394       SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
41395
41396 C...Double precision and integer declarations.
41397       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41398       IMPLICIT INTEGER(I-N)
41399       INTEGER PYK,PYCHGE,PYCOMP
41400 C...Commonblocks.
41401       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41402       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41403       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41404       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41405
41406 C...Standard checks.
41407       MSTU(28)=0
41408       IF(MSTU(12).GE.1) CALL PYLIST(0)
41409       IPA=MAX(1,IABS(IP))
41410       IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
41411      &'(PY1ENT:) writing outside PYJETS memory')
41412       KC=PYCOMP(KF)
41413       IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
41414
41415 C...Find mass. Reset K, P and V vectors.
41416       PM=0D0
41417       IF(MSTU(10).EQ.1) PM=P(IPA,5)
41418       IF(MSTU(10).GE.2) PM=PYMASS(KF)
41419       DO 100 J=1,5
41420         K(IPA,J)=0
41421         P(IPA,J)=0D0
41422         V(IPA,J)=0D0
41423   100 CONTINUE
41424
41425 C...Store parton/particle in K and P vectors.
41426       K(IPA,1)=1
41427       IF(IP.LT.0) K(IPA,1)=2
41428       K(IPA,2)=KF
41429       P(IPA,5)=PM
41430       P(IPA,4)=MAX(PE,PM)
41431       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
41432       P(IPA,1)=PA*SIN(THE)*COS(PHI)
41433       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
41434       P(IPA,3)=PA*COS(THE)
41435
41436 C...Set N. Optionally fragment/decay.
41437       N=IPA
41438       IF(IP.EQ.0) CALL PYEXEC
41439
41440       RETURN
41441       END
41442
41443 C*********************************************************************
41444
41445 C...PY2ENT
41446 C...Stores two partons/particles in their CM frame,
41447 C...with the first along the +z axis.
41448
41449       SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
41450
41451 C...Double precision and integer declarations.
41452       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41453       IMPLICIT INTEGER(I-N)
41454       INTEGER PYK,PYCHGE,PYCOMP
41455 C...Commonblocks.
41456       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41457       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41458       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41459       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41460
41461 C...Standard checks.
41462       MSTU(28)=0
41463       IF(MSTU(12).GE.1) CALL PYLIST(0)
41464       IPA=MAX(1,IABS(IP))
41465       IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
41466      &'(PY2ENT:) writing outside PYJETS memory')
41467       KC1=PYCOMP(KF1)
41468       KC2=PYCOMP(KF2)
41469       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
41470      &'(PY2ENT:) unknown flavour code')
41471
41472 C...Find masses. Reset K, P and V vectors.
41473       PM1=0D0
41474       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41475       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41476       PM2=0D0
41477       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41478       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41479       DO 110 I=IPA,IPA+1
41480         DO 100 J=1,5
41481           K(I,J)=0
41482           P(I,J)=0D0
41483           V(I,J)=0D0
41484   100   CONTINUE
41485   110 CONTINUE
41486
41487 C...Check flavours.
41488       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41489       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41490       IF(MSTU(19).EQ.1) THEN
41491         MSTU(19)=0
41492       ELSE
41493         IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
41494      &  '(PY2ENT:) unphysical flavour combination')
41495       ENDIF
41496       K(IPA,2)=KF1
41497       K(IPA+1,2)=KF2
41498
41499 C...Store partons/particles in K vectors for normal case.
41500       IF(IP.GE.0) THEN
41501         K(IPA,1)=1
41502         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
41503         K(IPA+1,1)=1
41504
41505 C...Store partons in K vectors for parton shower evolution.
41506       ELSE
41507         K(IPA,1)=3
41508         K(IPA+1,1)=3
41509         K(IPA,4)=MSTU(5)*(IPA+1)
41510         K(IPA,5)=K(IPA,4)
41511         K(IPA+1,4)=MSTU(5)*IPA
41512         K(IPA+1,5)=K(IPA+1,4)
41513       ENDIF
41514
41515 C...Check kinematics and store partons/particles in P vectors.
41516       IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
41517      &'(PY2ENT:) energy smaller than sum of masses')
41518       PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
41519      &(2D0*PECM)
41520       P(IPA,3)=PA
41521       P(IPA,4)=SQRT(PM1**2+PA**2)
41522       P(IPA,5)=PM1
41523       P(IPA+1,3)=-PA
41524       P(IPA+1,4)=SQRT(PM2**2+PA**2)
41525       P(IPA+1,5)=PM2
41526
41527 C...Set N. Optionally fragment/decay.
41528       N=IPA+1
41529       IF(IP.EQ.0) CALL PYEXEC
41530
41531       RETURN
41532       END
41533
41534 C*********************************************************************
41535
41536 C...PY3ENT
41537 C...Stores three partons or particles in their CM frame,
41538 C...with the first along the +z axis and the third in the (x,z)
41539 C...plane with x > 0.
41540
41541       SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
41542
41543 C...Double precision and integer declarations.
41544       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41545       IMPLICIT INTEGER(I-N)
41546       INTEGER PYK,PYCHGE,PYCOMP
41547 C...Commonblocks.
41548       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41549       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41550       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41551       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41552
41553 C...Standard checks.
41554       MSTU(28)=0
41555       IF(MSTU(12).GE.1) CALL PYLIST(0)
41556       IPA=MAX(1,IABS(IP))
41557       IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
41558      &'(PY3ENT:) writing outside PYJETS memory')
41559       KC1=PYCOMP(KF1)
41560       KC2=PYCOMP(KF2)
41561       KC3=PYCOMP(KF3)
41562       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
41563      &'(PY3ENT:) unknown flavour code')
41564
41565 C...Find masses. Reset K, P and V vectors.
41566       PM1=0D0
41567       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41568       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41569       PM2=0D0
41570       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41571       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41572       PM3=0D0
41573       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41574       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41575       DO 110 I=IPA,IPA+2
41576         DO 100 J=1,5
41577           K(I,J)=0
41578           P(I,J)=0D0
41579           V(I,J)=0D0
41580   100   CONTINUE
41581   110 CONTINUE
41582
41583 C...Check flavours.
41584       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41585       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41586       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41587       IF(MSTU(19).EQ.1) THEN
41588         MSTU(19)=0
41589       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
41590       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
41591      &  KQ1+KQ3.EQ.4)) THEN
41592       ELSE
41593         CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
41594       ENDIF
41595       K(IPA,2)=KF1
41596       K(IPA+1,2)=KF2
41597       K(IPA+2,2)=KF3
41598
41599 C...Store partons/particles in K vectors for normal case.
41600       IF(IP.GE.0) THEN
41601         K(IPA,1)=1
41602         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
41603         K(IPA+1,1)=1
41604         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
41605         K(IPA+2,1)=1
41606
41607 C...Store partons in K vectors for parton shower evolution.
41608       ELSE
41609         K(IPA,1)=3
41610         K(IPA+1,1)=3
41611         K(IPA+2,1)=3
41612         KCS=4
41613         IF(KQ1.EQ.-1) KCS=5
41614         K(IPA,KCS)=MSTU(5)*(IPA+1)
41615         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
41616         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41617         K(IPA+1,9-KCS)=MSTU(5)*IPA
41618         K(IPA+2,KCS)=MSTU(5)*IPA
41619         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41620       ENDIF
41621
41622 C...Check kinematics.
41623       MKERR=0
41624       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
41625      &0.5D0*X3*PECM.LE.PM3) MKERR=1
41626       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41627       PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
41628       PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
41629       CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
41630       CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
41631       IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
41632       CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
41633       IF(MKERR.NE.0) CALL PYERRM(13,
41634      &'(PY3ENT:) unphysical kinematical variable setup')
41635
41636 C...Store partons/particles in P vectors.
41637       P(IPA,3)=PA1
41638       P(IPA,4)=SQRT(PA1**2+PM1**2)
41639       P(IPA,5)=PM1
41640       P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
41641       P(IPA+2,3)=PA3*CTHE3
41642       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
41643       P(IPA+2,5)=PM3
41644       P(IPA+1,1)=-P(IPA+2,1)
41645       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
41646       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
41647       P(IPA+1,5)=PM2
41648
41649 C...Set N. Optionally fragment/decay.
41650       N=IPA+2
41651       IF(IP.EQ.0) CALL PYEXEC
41652
41653       RETURN
41654       END
41655
41656 C*********************************************************************
41657
41658 C...PY4ENT
41659 C...Stores four partons or particles in their CM frame, with
41660 C...the first along the +z axis, the last in the xz plane with x > 0
41661 C...and the second having y < 0 and y > 0 with equal probability.
41662
41663       SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
41664
41665 C...Double precision and integer declarations.
41666       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41667       IMPLICIT INTEGER(I-N)
41668       INTEGER PYK,PYCHGE,PYCOMP
41669 C...Commonblocks.
41670       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41671       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41672       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41673       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41674
41675 C...Standard checks.
41676       MSTU(28)=0
41677       IF(MSTU(12).GE.1) CALL PYLIST(0)
41678       IPA=MAX(1,IABS(IP))
41679       IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
41680      &'(PY4ENT:) writing outside PYJETS momory')
41681       KC1=PYCOMP(KF1)
41682       KC2=PYCOMP(KF2)
41683       KC3=PYCOMP(KF3)
41684       KC4=PYCOMP(KF4)
41685       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
41686      &'(PY4ENT:) unknown flavour code')
41687
41688 C...Find masses. Reset K, P and V vectors.
41689       PM1=0D0
41690       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41691       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41692       PM2=0D0
41693       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41694       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41695       PM3=0D0
41696       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41697       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41698       PM4=0D0
41699       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
41700       IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
41701       DO 110 I=IPA,IPA+3
41702         DO 100 J=1,5
41703           K(I,J)=0
41704           P(I,J)=0D0
41705           V(I,J)=0D0
41706   100   CONTINUE
41707   110 CONTINUE
41708
41709 C...Check flavours.
41710       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41711       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41712       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41713       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
41714       IF(MSTU(19).EQ.1) THEN
41715         MSTU(19)=0
41716       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
41717       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
41718      &  KQ1+KQ4.EQ.4)) THEN
41719       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
41720      &  THEN
41721       ELSE
41722         CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
41723       ENDIF
41724       K(IPA,2)=KF1
41725       K(IPA+1,2)=KF2
41726       K(IPA+2,2)=KF3
41727       K(IPA+3,2)=KF4
41728
41729 C...Store partons/particles in K vectors for normal case.
41730       IF(IP.GE.0) THEN
41731         K(IPA,1)=1
41732         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
41733         K(IPA+1,1)=1
41734         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
41735      &  K(IPA+1,1)=2
41736         K(IPA+2,1)=1
41737         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
41738         K(IPA+3,1)=1
41739
41740 C...Store partons for parton shower evolution from q-g-g-qbar or
41741 C...g-g-g-g event.
41742       ELSEIF(KQ1+KQ2.NE.0) THEN
41743         K(IPA,1)=3
41744         K(IPA+1,1)=3
41745         K(IPA+2,1)=3
41746         K(IPA+3,1)=3
41747         KCS=4
41748         IF(KQ1.EQ.-1) KCS=5
41749         K(IPA,KCS)=MSTU(5)*(IPA+1)
41750         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
41751         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41752         K(IPA+1,9-KCS)=MSTU(5)*IPA
41753         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
41754         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41755         K(IPA+3,KCS)=MSTU(5)*IPA
41756         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
41757
41758 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
41759       ELSE
41760         K(IPA,1)=3
41761         K(IPA+1,1)=3
41762         K(IPA+2,1)=3
41763         K(IPA+3,1)=3
41764         K(IPA,4)=MSTU(5)*(IPA+1)
41765         K(IPA,5)=K(IPA,4)
41766         K(IPA+1,4)=MSTU(5)*IPA
41767         K(IPA+1,5)=K(IPA+1,4)
41768         K(IPA+2,4)=MSTU(5)*(IPA+3)
41769         K(IPA+2,5)=K(IPA+2,4)
41770         K(IPA+3,4)=MSTU(5)*(IPA+2)
41771         K(IPA+3,5)=K(IPA+3,4)
41772       ENDIF
41773
41774 C...Check kinematics.
41775       MKERR=0
41776       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
41777      &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
41778      &MKERR=1
41779       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41780       PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
41781       PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
41782       X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
41783       CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
41784       IF(ABS(CTHE4).GE.1.002D0) MKERR=1
41785       CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
41786       STHE4=SQRT(1D0-CTHE4**2)
41787       CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
41788       IF(ABS(CTHE2).GE.1.002D0) MKERR=1
41789       CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
41790       STHE2=SQRT(1D0-CTHE2**2)
41791       CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
41792      &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
41793       IF(ABS(CPHI2).GE.1.05D0) MKERR=1
41794       CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
41795       IF(MKERR.EQ.1) CALL PYERRM(13,
41796      &'(PY4ENT:) unphysical kinematical variable setup')
41797
41798 C...Store partons/particles in P vectors.
41799       P(IPA,3)=PA1
41800       P(IPA,4)=SQRT(PA1**2+PM1**2)
41801       P(IPA,5)=PM1
41802       P(IPA+3,1)=PA4*STHE4
41803       P(IPA+3,3)=PA4*CTHE4
41804       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
41805       P(IPA+3,5)=PM4
41806       P(IPA+1,1)=PA2*STHE2*CPHI2
41807       P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
41808       P(IPA+1,3)=PA2*CTHE2
41809       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
41810       P(IPA+1,5)=PM2
41811       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
41812       P(IPA+2,2)=-P(IPA+1,2)
41813       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
41814       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
41815       P(IPA+2,5)=PM3
41816
41817 C...Set N. Optionally fragment/decay.
41818       N=IPA+3
41819       IF(IP.EQ.0) CALL PYEXEC
41820
41821       RETURN
41822       END
41823
41824 C*********************************************************************
41825
41826 C...PY2FRM
41827 C...An interface from a two-fermion generator to include
41828 C...parton showers and hadronization.
41829
41830       SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
41831
41832 C...Double precision and integer declarations.
41833       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41834       IMPLICIT INTEGER(I-N)
41835       INTEGER PYK,PYCHGE,PYCOMP
41836 C...Commonblocks.
41837       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41838       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41839       SAVE /PYJETS/,/PYDAT1/
41840 C...Local arrays.
41841       DIMENSION IJOIN(2),INTAU(2)
41842
41843 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41844       IF(ICOM.EQ.0) THEN
41845         MSTU(28)=0
41846         CALL PYHEPC(2)
41847       ENDIF
41848
41849 C...Loop through entries and pick up all final fermions/antifermions.
41850       I1=0
41851       I2=0
41852       DO 100 I=1,N
41853       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41854       KFA=IABS(K(I,2))
41855       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41856         IF(K(I,2).GT.0) THEN
41857           IF(I1.EQ.0) THEN
41858             I1=I
41859           ELSE
41860             CALL PYERRM(16,'(PY2FRM:) more than one fermion')
41861           ENDIF
41862         ELSE
41863           IF(I2.EQ.0) THEN
41864             I2=I
41865           ELSE
41866             CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
41867           ENDIF
41868         ENDIF
41869       ENDIF
41870   100 CONTINUE
41871
41872 C...Check that event is arranged according to conventions.
41873       IF(I1.EQ.0.OR.I2.EQ.0) THEN
41874         CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
41875       ENDIF
41876       IF(I2.LT.I1) THEN
41877         CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
41878       ENDIF
41879
41880 C...Check whether fermion pair is quarks or leptons.
41881       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
41882         IQL12=1
41883       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
41884         IQL12=2
41885       ELSE
41886         CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
41887       ENDIF
41888
41889 C...Decide whether to allow or not photon radiation in showers.
41890       MSTJ(41)=2
41891       IF(IRAD.EQ.0) MSTJ(41)=1
41892
41893 C...Do colour joining and parton showers.
41894       IP1=I1
41895       IP2=I2
41896       IF(IQL12.EQ.1) THEN
41897         IJOIN(1)=IP1
41898         IJOIN(2)=IP2
41899         CALL PYJOIN(2,IJOIN)
41900       ENDIF
41901       IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
41902         PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
41903      &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
41904         CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
41905       ENDIF
41906
41907 C...Do fragmentation and decays. Possibly except tau decay.
41908       IF(ITAU.EQ.0) THEN
41909         NTAU=0
41910         DO 110 I=1,N
41911         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
41912           NTAU=NTAU+1
41913           INTAU(NTAU)=I
41914           K(I,1)=11
41915         ENDIF
41916   110   CONTINUE
41917       ENDIF
41918       CALL PYEXEC
41919       IF(ITAU.EQ.0) THEN
41920         DO 120 I=1,NTAU
41921         K(INTAU(I),1)=1
41922   120   CONTINUE
41923       ENDIF
41924
41925 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
41926       IF(ICOM.EQ.0) THEN
41927         MSTU(28)=0
41928         CALL PYHEPC(1)
41929       ENDIF
41930
41931       END
41932
41933 C*********************************************************************
41934
41935 C...PY4FRM
41936 C...An interface from a four-fermion generator to include
41937 C...parton showers and hadronization.
41938
41939       SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
41940
41941 C...Double precision and integer declarations.
41942       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41943       IMPLICIT INTEGER(I-N)
41944       INTEGER PYK,PYCHGE,PYCOMP
41945 C...Commonblocks.
41946       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41947       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41948       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41949       COMMON/PYINT1/MINT(400),VINT(400)
41950       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
41951 C...Local arrays.
41952       DIMENSION IJOIN(2),INTAU(4)
41953
41954 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41955       IF(ICOM.EQ.0) THEN
41956         MSTU(28)=0
41957         CALL PYHEPC(2)
41958       ENDIF
41959
41960 C...Loop through entries and pick up all final fermions/antifermions.
41961       I1=0
41962       I2=0
41963       I3=0
41964       I4=0
41965       DO 100 I=1,N
41966       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41967       KFA=IABS(K(I,2))
41968       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41969         IF(K(I,2).GT.0) THEN
41970           IF(I1.EQ.0) THEN
41971             I1=I
41972           ELSEIF(I3.EQ.0) THEN
41973             I3=I
41974           ELSE
41975             CALL PYERRM(16,'(PY4FRM:) more than two fermions')
41976           ENDIF
41977         ELSE
41978           IF(I2.EQ.0) THEN
41979             I2=I
41980           ELSEIF(I4.EQ.0) THEN
41981             I4=I
41982           ELSE
41983             CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
41984           ENDIF
41985         ENDIF
41986       ENDIF
41987   100 CONTINUE
41988
41989 C...Check that event is arranged according to conventions.
41990       IF(I3.EQ.0.OR.I4.EQ.0) THEN
41991         CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
41992       ENDIF
41993       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
41994         CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
41995       ENDIF
41996
41997 C...Check which fermion pairs are quarks and which leptons.
41998       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
41999         IQL12=1
42000       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42001         IQL12=2
42002       ELSE
42003         CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
42004       ENDIF
42005       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42006         IQL34=1
42007       ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42008         IQL34=2
42009       ELSE
42010         CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
42011       ENDIF
42012
42013 C...Decide whether to allow or not photon radiation in showers.
42014       MSTJ(41)=2
42015       IF(IRAD.EQ.0) MSTJ(41)=1
42016
42017 C...Decide on dipole pairing.
42018       IP1=I1
42019       IP2=I2
42020       IP3=I3
42021       IP4=I4
42022       IF(IQL12.EQ.IQL34) THEN
42023         R1SQ=A1SQ
42024         R2SQ=A2SQ
42025         DELTA=ATOTSQ-A1SQ-A2SQ
42026         IF(ISTRAT.EQ.1) THEN
42027           IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
42028           IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
42029         ELSEIF(ISTRAT.EQ.2) THEN
42030           IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
42031           IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
42032         ENDIF
42033         IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
42034           IP2=I4
42035           IP4=I2
42036         ENDIF
42037       ENDIF
42038
42039 C...If colour reconnection then bookkeep W+W- or Z0Z0
42040 C...and copy q qbar q qbar consecutively.
42041       IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42042         K(N+1,1)=11
42043         K(N+1,3)=IP1
42044         K(N+1,4)=N+3
42045         K(N+1,5)=N+4
42046         K(N+2,1)=11
42047         K(N+2,3)=IP3
42048         K(N+2,4)=N+5
42049         K(N+2,5)=N+6
42050         IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
42051           K(N+1,2)=23
42052           K(N+2,2)=23
42053           MINT(1)=22
42054         ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
42055           K(N+1,2)=24
42056           K(N+2,2)=-24
42057           MINT(1)=25
42058         ELSE
42059           K(N+1,2)=-24
42060           K(N+2,2)=24
42061           MINT(1)=25
42062         ENDIF
42063         DO 110 J=1,5
42064           K(N+3,J)=K(IP1,J)
42065           K(N+4,J)=K(IP2,J)
42066           K(N+5,J)=K(IP3,J)
42067           K(N+6,J)=K(IP4,J)
42068           P(N+1,J)=P(IP1,J)+P(IP2,J)
42069           P(N+2,J)=P(IP3,J)+P(IP4,J)
42070           P(N+3,J)=P(IP1,J)
42071           P(N+4,J)=P(IP2,J)
42072           P(N+5,J)=P(IP3,J)
42073           P(N+6,J)=P(IP4,J)
42074           V(N+1,J)=V(IP1,J)
42075           V(N+2,J)=V(IP3,J)
42076           V(N+3,J)=V(IP1,J)
42077           V(N+4,J)=V(IP2,J)
42078           V(N+5,J)=V(IP3,J)
42079           V(N+6,J)=V(IP4,J)
42080   110   CONTINUE
42081         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42082      &  P(N+1,3)**2))
42083         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42084      &  P(N+2,3)**2))
42085         K(N+3,3)=N+1
42086         K(N+4,3)=N+1
42087         K(N+5,3)=N+2
42088         K(N+6,3)=N+2
42089 C...Remove original q qbar q qbar and update counters.
42090         K(IP1,1)=K(IP1,1)+10
42091         K(IP2,1)=K(IP2,1)+10
42092         K(IP3,1)=K(IP3,1)+10
42093         K(IP4,1)=K(IP4,1)+10
42094         IW1=N+1
42095         IW2=N+2
42096         NSD1=N+2
42097         IP1=N+3
42098         IP2=N+4
42099         IP3=N+5
42100         IP4=N+6
42101         N=N+6
42102       ENDIF
42103
42104 C...Do colour joinings and parton showers.
42105       IF(IQL12.EQ.1) THEN
42106         IJOIN(1)=IP1
42107         IJOIN(2)=IP2
42108         CALL PYJOIN(2,IJOIN)
42109       ENDIF
42110       IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42111         PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42112      &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42113         CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42114       ENDIF
42115       NAFT1=N
42116       IF(IQL34.EQ.1) THEN
42117         IJOIN(1)=IP3
42118         IJOIN(2)=IP4
42119         CALL PYJOIN(2,IJOIN)
42120       ENDIF
42121       IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42122         PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42123      &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42124         CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42125       ENDIF
42126
42127 C...Optionally do colour reconnection.
42128       MINT(32)=0
42129       MSTI(32)=0
42130       IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42131         CALL PYRECO(IW1,IW2,NSD1,NAFT1)
42132         MSTI(32)=MINT(32)
42133       ENDIF
42134
42135 C...Do fragmentation and decays. Possibly except tau decay.
42136       IF(ITAU.EQ.0) THEN
42137         NTAU=0
42138         DO 120 I=1,N
42139         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42140           NTAU=NTAU+1
42141           INTAU(NTAU)=I
42142           K(I,1)=11
42143         ENDIF
42144   120   CONTINUE
42145       ENDIF
42146       CALL PYEXEC
42147       IF(ITAU.EQ.0) THEN
42148         DO 130 I=1,NTAU
42149         K(INTAU(I),1)=1
42150   130   CONTINUE
42151       ENDIF
42152
42153 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42154       IF(ICOM.EQ.0) THEN
42155         MSTU(28)=0
42156         CALL PYHEPC(1)
42157       ENDIF
42158
42159       END
42160
42161 C*********************************************************************
42162
42163 C...PY6FRM
42164 C...An interface from a six-fermion generator to include
42165 C...parton showers and hadronization.
42166
42167       SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
42168
42169 C...Double precision and integer declarations.
42170       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42171       IMPLICIT INTEGER(I-N)
42172       INTEGER PYK,PYCHGE,PYCOMP
42173 C...Commonblocks.
42174       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42175       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42176       SAVE /PYJETS/,/PYDAT1/
42177 C...Local arrays.
42178       DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
42179
42180 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42181       IF(ICOM.EQ.0) THEN
42182         MSTU(28)=0
42183         CALL PYHEPC(2)
42184       ENDIF
42185
42186 C...Loop through entries and pick up all final fermions/antifermions.
42187       I1=0
42188       I2=0
42189       I3=0
42190       I4=0
42191       I5=0
42192       I6=0
42193       DO 100 I=1,N
42194       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42195       KFA=IABS(K(I,2))
42196       IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
42197         IF(K(I,2).GT.0) THEN
42198           IF(I1.EQ.0) THEN
42199             I1=I
42200           ELSEIF(I3.EQ.0) THEN
42201             I3=I
42202           ELSEIF(I5.EQ.0) THEN
42203             I5=I
42204           ELSE
42205             CALL PYERRM(16,'(PY6FRM:) more than three fermions')
42206           ENDIF
42207         ELSE
42208           IF(I2.EQ.0) THEN
42209             I2=I
42210           ELSEIF(I4.EQ.0) THEN
42211             I4=I
42212           ELSEIF(I6.EQ.0) THEN
42213             I6=I
42214           ELSE
42215             CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
42216           ENDIF
42217         ENDIF
42218       ENDIF
42219   100 CONTINUE
42220
42221 C...Check that event is arranged according to conventions.
42222       IF(I5.EQ.0.OR.I6.EQ.0) THEN
42223         CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
42224       ENDIF
42225       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
42226         CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
42227       ENDIF
42228
42229 C...Check which fermion pairs are quarks and which leptons.
42230       IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
42231         IQL12=1
42232       ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42233         IQL12=2
42234       ELSE
42235         CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
42236       ENDIF
42237       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42238         IQL34=1
42239       ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42240         IQL34=2
42241       ELSE
42242         CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
42243       ENDIF
42244       IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
42245         IQL56=1
42246       ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
42247         IQL56=2
42248       ELSE
42249         CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
42250       ENDIF
42251
42252 C...Decide whether to allow or not photon radiation in showers.
42253       MSTJ(41)=2
42254       IF(IRAD.EQ.0) MSTJ(41)=1
42255
42256 C...Allow dipole pairings only among leptons and quarks separately.
42257       P12D=P12
42258       P13D=0D0
42259       IF(IQL34.EQ.IQL56) P13D=P13
42260       P21D=0D0
42261       IF(IQL12.EQ.IQL34) P21D=P21
42262       P23D=0D0
42263       IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
42264       P31D=0D0
42265       IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
42266       P32D=0D0
42267       IF(IQL12.EQ.IQL56) P32D=P32
42268
42269 C...Decide whether t+tbar.
42270       ITOP=0
42271       IF(PYR(0).LT.PTOP) THEN
42272         ITOP=1
42273
42274 C...If t+tbar: reconstruct t's.
42275         IT=N+1
42276         ITB=N+2
42277         DO 110 J=1,5
42278           K(IT,J)=0
42279           K(ITB,J)=0
42280           P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
42281           P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
42282           V(IT,J)=0D0
42283           V(ITB,J)=0D0
42284   110   CONTINUE
42285         K(IT,1)=1
42286         K(ITB,1)=1
42287         K(IT,2)=6
42288         K(ITB,2)=-6
42289         P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
42290      &  P(IT,3)**2))
42291         P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
42292      &  P(ITB,3)**2))
42293         N=N+2
42294
42295 C...If t+tbar: colour join t's and let them shower.
42296         IJOIN(1)=IT
42297         IJOIN(2)=ITB
42298         CALL PYJOIN(2,IJOIN)
42299         PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
42300      &  (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
42301         CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
42302
42303 C...If t+tbar: pick up the t's after shower.
42304         ITNEW=IT
42305         ITBNEW=ITB
42306         DO 120 I=ITB+1,N
42307           IF(K(I,2).EQ.6) ITNEW=I
42308           IF(K(I,2).EQ.-6) ITBNEW=I
42309   120   CONTINUE
42310
42311 C...If t+tbar: loop over two top systems.
42312         DO 200 IT1=1,2
42313           IF(IT1.EQ.1) THEN
42314             ITO=IT
42315             ITN=ITNEW
42316             IBO=I1
42317             IW1=I3
42318             IW2=I4
42319           ELSE
42320             ITO=ITB
42321             ITN=ITBNEW
42322             IBO=I2
42323             IW1=I5
42324             IW2=I6
42325           ENDIF
42326           IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
42327      &    '(PY6FRM:) not b in t decay')
42328
42329 C...If t+tbar: find boost from original to new top frame.
42330           DO 130 J=1,3
42331             BETAO(J)=P(ITO,J)/P(ITO,4)
42332             BETAN(J)=P(ITN,J)/P(ITN,4)
42333   130     CONTINUE
42334
42335 C...If t+tbar: boost copy of b by t shower and connect it in colour.
42336           N=N+1
42337           IB=N
42338           K(IB,1)=3
42339           K(IB,2)=K(IBO,2)
42340           K(IB,3)=ITN
42341           DO 140 J=1,5
42342             P(IB,J)=P(IBO,J)
42343             V(IB,J)=0D0
42344   140     CONTINUE
42345           CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42346           CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42347           K(IB,4)=MSTU(5)*ITN
42348           K(IB,5)=MSTU(5)*ITN
42349           K(ITN,4)=K(ITN,4)+IB
42350           K(ITN,5)=K(ITN,5)+IB
42351           K(ITN,1)=K(ITN,1)+10
42352           K(IBO,1)=K(IBO,1)+10
42353
42354 C...If t+tbar: construct W recoiling against b.
42355           N=N+1
42356           IW=N
42357           DO 150 J=1,5
42358             K(IW,J)=0
42359             V(IW,J)=0D0
42360   150     CONTINUE
42361           K(IW,1)=1
42362           KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
42363           IF(IABS(KCHW).EQ.3) THEN
42364             K(IW,2)=ISIGN(24,KCHW)
42365           ELSE
42366             CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
42367           ENDIF
42368           K(IW,3)=IW1
42369
42370 C...If t+tbar: construct W momentum, including boost by t shower.
42371           DO 160 J=1,4
42372             P(IW,J)=P(IW1,J)+P(IW2,J)
42373   160     CONTINUE
42374           P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
42375      &    P(IW,3)**2))
42376           CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42377           CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42378
42379 C...If t+tbar: boost b and W to top rest frame.
42380           DO 170 J=1,3
42381             BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
42382   170     CONTINUE
42383           CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42384           CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42385
42386 C...If t+tbar: let b shower and pick up modified W.
42387           PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
42388      &    (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
42389           CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
42390           DO 180 I=IW,N
42391             IF(IABS(K(I,2)).EQ.24) IWM=I
42392   180     CONTINUE
42393
42394 C...If t+tbar: take copy of W decay products.
42395           DO 190 J=1,5
42396             K(N+1,J)=K(IW1,J)
42397             P(N+1,J)=P(IW1,J)
42398             V(N+1,J)=V(IW1,J)
42399             K(N+2,J)=K(IW2,J)
42400             P(N+2,J)=P(IW2,J)
42401             V(N+2,J)=V(IW2,J)
42402   190     CONTINUE
42403           K(IW1,1)=K(IW1,1)+10
42404           K(IW2,1)=K(IW2,1)+10
42405           K(IWM,1)=K(IWM,1)+10
42406           K(IWM,4)=N+1
42407           K(IWM,5)=N+2
42408           K(N+1,3)=IWM
42409           K(N+2,3)=IWM
42410           IF(IT1.EQ.1) THEN
42411             I3=N+1
42412             I4=N+2
42413           ELSE
42414             I5=N+1
42415             I6=N+2
42416           ENDIF
42417           N=N+2
42418
42419 C...If t+tbar: boost W decay products, first by effects of t shower,
42420 C...then by those of b shower. b and its shower simple boost back.
42421           CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42422           CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42423           CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42424           CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
42425      &    -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
42426           CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
42427      &    P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
42428           CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
42429           CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
42430   200   CONTINUE
42431       ENDIF
42432
42433 C...Decide on dipole pairing.
42434       IP1=I1
42435       IP3=I3
42436       IP5=I5
42437       PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
42438       IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
42439         IP2=I2
42440         IP4=I4
42441         IP6=I6
42442       ELSEIF(PRN.LT.P12D+P13D) THEN
42443         IP2=I2
42444         IP4=I6
42445         IP6=I4
42446       ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
42447         IP2=I4
42448         IP4=I2
42449         IP6=I6
42450       ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
42451         IP2=I4
42452         IP4=I6
42453         IP6=I2
42454       ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
42455         IP2=I6
42456         IP4=I2
42457         IP6=I4
42458       ELSE
42459         IP2=I6
42460         IP4=I4
42461         IP6=I2
42462       ENDIF
42463
42464 C...Do colour joinings and parton showers
42465 C...(except ones already made for t+tbar).
42466       IF(ITOP.EQ.0) THEN
42467         IF(IQL12.EQ.1) THEN
42468           IJOIN(1)=IP1
42469           IJOIN(2)=IP2
42470           CALL PYJOIN(2,IJOIN)
42471         ENDIF
42472         IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42473           PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42474      &    (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42475           CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42476         ENDIF
42477       ENDIF
42478       IF(IQL34.EQ.1) THEN
42479         IJOIN(1)=IP3
42480         IJOIN(2)=IP4
42481         CALL PYJOIN(2,IJOIN)
42482       ENDIF
42483       IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42484         PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42485      &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42486         CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42487       ENDIF
42488       IF(IQL56.EQ.1) THEN
42489         IJOIN(1)=IP5
42490         IJOIN(2)=IP6
42491         CALL PYJOIN(2,IJOIN)
42492       ENDIF
42493       IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
42494         PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
42495      &  (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
42496         CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
42497       ENDIF
42498
42499 C...Do fragmentation and decays. Possibly except tau decay.
42500       IF(ITAU.EQ.0) THEN
42501         NTAU=0
42502         DO 210 I=1,N
42503         IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42504           NTAU=NTAU+1
42505           INTAU(NTAU)=I
42506           K(I,1)=11
42507         ENDIF
42508   210   CONTINUE
42509       ENDIF
42510       CALL PYEXEC
42511       IF(ITAU.EQ.0) THEN
42512         DO 220 I=1,NTAU
42513         K(INTAU(I),1)=1
42514   220   CONTINUE
42515       ENDIF
42516
42517 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42518       IF(ICOM.EQ.0) THEN
42519         MSTU(28)=0
42520         CALL PYHEPC(1)
42521       ENDIF
42522
42523       END
42524
42525 C*********************************************************************
42526
42527 C...PY4JET
42528 C...An interface from a four-parton generator to include
42529 C...parton showers and hadronization.
42530
42531       SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
42532
42533 C...Double precision and integer declarations.
42534       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42535       IMPLICIT INTEGER(I-N)
42536       INTEGER PYK,PYCHGE,PYCOMP
42537 C...Commonblocks.
42538       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42539       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42540       SAVE /PYJETS/,/PYDAT1/
42541 C...Local arrays.
42542       DIMENSION IJOIN(2),PTOT(4),BETA(3)
42543
42544 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42545       IF(ICOM.EQ.0) THEN
42546         MSTU(28)=0
42547         CALL PYHEPC(2)
42548       ENDIF
42549
42550 C...Loop through entries and pick up all final partons.
42551       I1=0
42552       I2=0
42553       I3=0
42554       I4=0
42555       DO 100 I=1,N
42556       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42557       KFA=IABS(K(I,2))
42558       IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
42559         IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
42560           IF(I1.EQ.0) THEN
42561             I1=I
42562           ELSEIF(I3.EQ.0) THEN
42563             I3=I
42564           ELSE
42565             CALL PYERRM(16,'(PY4JET:) more than two quarks')
42566           ENDIF
42567         ELSEIF(K(I,2).LT.0) THEN
42568           IF(I2.EQ.0) THEN
42569             I2=I
42570           ELSEIF(I4.EQ.0) THEN
42571             I4=I
42572           ELSE
42573             CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
42574           ENDIF
42575         ELSE
42576           IF(I3.EQ.0) THEN
42577             I3=I
42578           ELSEIF(I4.EQ.0) THEN
42579             I4=I
42580           ELSE
42581             CALL PYERRM(16,'(PY4JET:) more than two gluons')
42582           ENDIF
42583         ENDIF
42584       ENDIF
42585   100 CONTINUE
42586
42587 C...Check that event is arranged according to conventions.
42588       IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
42589         CALL PYERRM(16,'(PY4JET:) event contains too few partons')
42590       ENDIF
42591       IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
42592         CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
42593       ENDIF
42594
42595 C...Check whether second pair are quarks or gluons.
42596       IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42597         IQG34=1
42598       ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
42599         IQG34=2
42600       ELSE
42601         CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
42602       ENDIF
42603
42604 C...Boost partons to their cm frame.
42605       DO 110 J=1,4
42606         PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
42607   110 CONTINUE
42608       ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
42609       DO 120 J=1,3
42610         BETA(J)=PTOT(J)/PTOT(4)
42611   120 CONTINUE
42612       CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42613       CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42614       CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42615       CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42616       NSAV=N
42617
42618 C...Decide and set up shower history for q qbar q' qbar' events.
42619       IF(IQG34.EQ.1) THEN
42620         W1=PY4JTW(0,I1,I3,I4)
42621         W2=PY4JTW(0,I2,I3,I4)
42622         IF(W1.GT.PYR(0)*(W1+W2)) THEN
42623           CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42624         ELSE
42625           CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42626         ENDIF
42627
42628 C...Decide and set up shower history for q qbar g g events.
42629       ELSE
42630         W1=PY4JTW(I1,I3,I2,I4)
42631         W2=PY4JTW(I1,I4,I2,I3)
42632         W3=PY4JTW(0,I3,I1,I4)
42633         W4=PY4JTW(0,I4,I1,I3)
42634         W5=PY4JTW(0,I3,I2,I4)
42635         W6=PY4JTW(0,I4,I2,I3)
42636         W7=PY4JTW(0,I1,I3,I4)
42637         W8=PY4JTW(0,I2,I3,I4)
42638         WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
42639         IF(W1.GT.WR) THEN
42640           CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
42641         ELSEIF(W1+W2.GT.WR) THEN
42642           CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
42643         ELSEIF(W1+W2+W3.GT.WR) THEN
42644           CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
42645         ELSEIF(W1+W2+W3+W4.GT.WR) THEN
42646           CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
42647         ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
42648           CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
42649         ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
42650           CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
42651         ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
42652           CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42653         ELSE
42654           CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42655         ENDIF
42656       ENDIF
42657
42658 C...Boost back original partons and mark them as deleted.
42659       CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
42660       CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
42661       CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
42662       CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
42663       K(I1,1)=K(I1,1)+10
42664       K(I2,1)=K(I2,1)+10
42665       K(I3,1)=K(I3,1)+10
42666       K(I4,1)=K(I4,1)+10
42667
42668 C...Rotate shower initiating partons to be along z axis.
42669       PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
42670       CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
42671       THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
42672       CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
42673
42674 C...Set up copy of shower initiating partons as on mass shell.
42675       DO 140 I=N+1,N+2
42676         DO 130 J=1,5
42677           K(I,J)=0
42678           P(I,J)=0D0
42679           V(I,J)=V(I1,J)
42680   130   CONTINUE
42681         K(I,1)=1
42682         K(I,2)=K(I-6,2)
42683   140 CONTINUE
42684       IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
42685         K(N+1,3)=I1
42686         P(N+1,5)=P(I1,5)
42687         K(N+2,3)=I2
42688         P(N+2,5)=P(I2,5)
42689       ELSE
42690         K(N+1,3)=I2
42691         P(N+1,5)=P(I2,5)
42692         K(N+2,3)=I1
42693         P(N+2,5)=P(I1,5)
42694       ENDIF
42695       PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
42696      &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
42697       P(N+1,3)=PABS
42698       P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
42699       P(N+2,3)=-PABS
42700       P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
42701       N=N+2
42702
42703 C...Decide whether to allow or not photon radiation in showers.
42704 C...Connect up colours.
42705       MSTJ(41)=2
42706       IF(IRAD.EQ.0) MSTJ(41)=1
42707       IJOIN(1)=N-1
42708       IJOIN(2)=N
42709       CALL PYJOIN(2,IJOIN)
42710
42711 C...Decide on maximum virtuality and do parton shower.
42712       IF(PMAX.LT.PARJ(82)) THEN
42713         PQMAX=QMAX
42714       ELSE
42715         PQMAX=PMAX
42716       ENDIF
42717       CALL PYSHOW(NSAV+1,-8,PQMAX)
42718
42719 C...Rotate and boost back system.
42720       CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
42721
42722 C...Do fragmentation and decays.
42723       CALL PYEXEC
42724
42725 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42726       IF(ICOM.EQ.0) THEN
42727         MSTU(28)=0
42728         CALL PYHEPC(1)
42729       ENDIF
42730
42731       RETURN
42732       END
42733
42734 C*********************************************************************
42735
42736 C...PY4JTW
42737 C...Auxiliary to PY4JET, to evaluate weight of configuration.
42738
42739       FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
42740
42741 C...Double precision and integer declarations.
42742       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42743       IMPLICIT INTEGER(I-N)
42744       INTEGER PYK,PYCHGE,PYCOMP
42745 C...Commonblocks.
42746       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42747       SAVE /PYJETS/
42748
42749 C...First case: when both original partons radiate.
42750 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
42751       IF(IA1.NE.0) THEN
42752         DO 100 J=1,4
42753           P(N+1,J)=P(IA1,J)+P(IA2,J)
42754           P(N+2,J)=P(IA3,J)+P(IA4,J)
42755   100   CONTINUE
42756         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42757      &  P(N+1,3)**2))
42758         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42759      &  P(N+2,3)**2))
42760         Z1=P(IA1,4)/P(N+1,4)
42761         WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
42762         Z2=P(IA3,4)/P(N+2,4)
42763         WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
42764
42765 C...Second case: when one original parton radiates to three.
42766 C...IA1  = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
42767       ELSE
42768         DO 110 J=1,4
42769           P(N+2,J)=P(IA3,J)+P(IA4,J)
42770           P(N+1,J)=P(N+2,J)+P(IA2,J)
42771   110   CONTINUE
42772         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42773      &  P(N+1,3)**2))
42774         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42775      &  P(N+2,3)**2))
42776         IF(K(IA2,2).EQ.21) THEN
42777           Z1=P(N+2,4)/P(N+1,4)
42778           WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42779      &    P(IA3,5)**2)
42780         ELSE
42781           Z1=P(IA2,4)/P(N+1,4)
42782           WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42783      &    P(IA2,5)**2)
42784         ENDIF
42785         Z2=P(IA3,4)/P(N+2,4)
42786         IF(K(IA2,2).EQ.21) THEN
42787           WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
42788      &    P(IA3,5)**2)
42789         ELSEIF(K(IA3,2).EQ.21) THEN
42790           WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
42791         ELSE
42792           WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
42793         ENDIF
42794       ENDIF
42795
42796 C...Total weight.
42797       PY4JTW=WT1*WT2
42798
42799       RETURN
42800       END
42801
42802 C*********************************************************************
42803
42804 C...PY4JTS
42805 C...Auxiliary to PY4JET, to set up chosen configuration.
42806
42807       SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
42808
42809 C...Double precision and integer declarations.
42810       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42811       IMPLICIT INTEGER(I-N)
42812       INTEGER PYK,PYCHGE,PYCOMP
42813 C...Commonblocks.
42814       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42815       SAVE /PYJETS/
42816
42817 C...Reset info.
42818       DO 110 I=N+1,N+6
42819         DO 100 J=1,5
42820           K(I,J)=0
42821           V(I,J)=V(IA2,J)
42822   100   CONTINUE
42823         K(I,1)=16
42824   110 CONTINUE
42825
42826 C...First case: when both original partons radiate.
42827 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
42828       IF(IA1.NE.0) THEN
42829
42830 C...Set up flavour and history pointers for new partons.
42831         K(N+1,2)=K(IA1,2)
42832         K(N+2,2)=K(IA3,2)
42833         K(N+3,2)=K(IA1,2)
42834         K(N+4,2)=K(IA2,2)
42835         K(N+5,2)=K(IA3,2)
42836         K(N+6,2)=K(IA4,2)
42837         K(N+1,3)=IA1
42838         K(N+1,4)=N+3
42839         K(N+1,5)=N+4
42840         K(N+2,3)=IA3
42841         K(N+2,4)=N+5
42842         K(N+2,5)=N+6
42843         K(N+3,3)=N+1
42844         K(N+4,3)=N+1
42845         K(N+5,3)=N+2
42846         K(N+6,3)=N+2
42847
42848 C...Set up momenta for new partons.
42849         DO 120 J=1,5
42850           P(N+1,J)=P(IA1,J)+P(IA2,J)
42851           P(N+2,J)=P(IA3,J)+P(IA4,J)
42852           P(N+3,J)=P(IA1,J)
42853           P(N+4,J)=P(IA2,J)
42854           P(N+5,J)=P(IA3,J)
42855           P(N+6,J)=P(IA4,J)
42856   120   CONTINUE
42857         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42858      &  P(N+1,3)**2))
42859         P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42860      &  P(N+2,3)**2))
42861         QMAX=MIN(P(N+1,5),P(N+2,5))
42862
42863 C...Second case: q radiates twice.
42864 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
42865 C...IA5=N+2 does not radiate.
42866       ELSEIF(K(IA2,2).EQ.21) THEN
42867
42868 C...Set up flavour and history pointers for new partons.
42869         K(N+1,2)=K(IA3,2)
42870         K(N+2,2)=K(IA5,2)
42871         K(N+3,2)=K(IA3,2)
42872         K(N+4,2)=K(IA2,2)
42873         K(N+5,2)=K(IA3,2)
42874         K(N+6,2)=K(IA4,2)
42875         K(N+1,3)=IA3
42876         K(N+1,4)=N+3
42877         K(N+1,5)=N+4
42878         K(N+2,3)=IA5
42879         K(N+3,3)=N+1
42880         K(N+3,4)=N+5
42881         K(N+3,5)=N+6
42882         K(N+4,3)=N+1
42883         K(N+5,3)=N+3
42884         K(N+6,3)=N+3
42885
42886 C...Set up momenta for new partons.
42887         DO 130 J=1,5
42888           P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42889           P(N+2,J)=P(IA5,J)
42890           P(N+3,J)=P(IA3,J)+P(IA4,J)
42891           P(N+4,J)=P(IA2,J)
42892           P(N+5,J)=P(IA3,J)
42893           P(N+6,J)=P(IA4,J)
42894   130   CONTINUE
42895         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42896      &  P(N+1,3)**2))
42897         P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
42898      &  P(N+3,3)**2))
42899         QMAX=P(N+3,5)
42900
42901 C...Third case: q radiates g, g branches.
42902 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
42903 C...IA5=N+2 does not radiate.
42904       ELSE
42905
42906 C...Set up flavour and history pointers for new partons.
42907         K(N+1,2)=K(IA2,2)
42908         K(N+2,2)=K(IA5,2)
42909         K(N+3,2)=K(IA2,2)
42910         K(N+4,2)=21
42911         K(N+5,2)=K(IA3,2)
42912         K(N+6,2)=K(IA4,2)
42913         K(N+1,3)=IA2
42914         K(N+1,4)=N+3
42915         K(N+1,5)=N+4
42916         K(N+2,3)=IA5
42917         K(N+3,3)=N+1
42918         K(N+4,3)=N+1
42919         K(N+4,4)=N+5
42920         K(N+4,5)=N+6
42921         K(N+5,3)=N+4
42922         K(N+6,3)=N+4
42923
42924 C...Set up momenta for new partons.
42925         DO 140 J=1,5
42926           P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42927           P(N+2,J)=P(IA5,J)
42928           P(N+3,J)=P(IA2,J)
42929           P(N+4,J)=P(IA3,J)+P(IA4,J)
42930           P(N+5,J)=P(IA3,J)
42931           P(N+6,J)=P(IA4,J)
42932   140   CONTINUE
42933         P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42934      &  P(N+1,3)**2))
42935         P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
42936      &  P(N+4,3)**2))
42937         QMAX=P(N+4,5)
42938
42939       ENDIF
42940       N=N+6
42941
42942       RETURN
42943       END
42944
42945 C*********************************************************************
42946
42947 C...PYJOIN
42948 C...Connects a sequence of partons with colour flow indices,
42949 C...as required for subsequent shower evolution (or other operations).
42950
42951       SUBROUTINE PYJOIN(NJOIN,IJOIN)
42952
42953 C...Double precision and integer declarations.
42954       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42955       IMPLICIT INTEGER(I-N)
42956       INTEGER PYK,PYCHGE,PYCOMP
42957 C...Commonblocks.
42958       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42959       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42960       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42961       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42962 C...Local array.
42963       DIMENSION IJOIN(*)
42964
42965 C...Check that partons are of right types to be connected.
42966       IF(NJOIN.LT.2) GOTO 120
42967       KQSUM=0
42968       DO 100 IJN=1,NJOIN
42969         I=IJOIN(IJN)
42970         IF(I.LE.0.OR.I.GT.N) GOTO 120
42971         IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
42972         KC=PYCOMP(K(I,2))
42973         IF(KC.EQ.0) GOTO 120
42974         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
42975         IF(KQ.EQ.0) GOTO 120
42976         IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
42977         IF(KQ.NE.2) KQSUM=KQSUM+KQ
42978         IF(IJN.EQ.1) KQS=KQ
42979   100 CONTINUE
42980       IF(KQSUM.NE.0) GOTO 120
42981
42982 C...Connect the partons sequentially (closing for gluon loop).
42983       KCS=(9-KQS)/2
42984       IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
42985       DO 110 IJN=1,NJOIN
42986         I=IJOIN(IJN)
42987         K(I,1)=3
42988         IF(IJN.NE.1) IP=IJOIN(IJN-1)
42989         IF(IJN.EQ.1) IP=IJOIN(NJOIN)
42990         IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
42991         IF(IJN.EQ.NJOIN) IN=IJOIN(1)
42992         K(I,KCS)=MSTU(5)*IN
42993         K(I,9-KCS)=MSTU(5)*IP
42994         IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
42995         IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
42996   110 CONTINUE
42997
42998 C...Error exit: no action taken.
42999       RETURN
43000   120 CALL PYERRM(12,
43001      &'(PYJOIN:) given entries can not be joined by one string')
43002
43003       RETURN
43004       END
43005
43006 C*********************************************************************
43007
43008 C...PYGIVE
43009 C...Sets values of commonblock variables.
43010
43011       SUBROUTINE PYGIVE(CHIN)
43012
43013 C...Double precision and integer declarations.
43014       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43015       IMPLICIT INTEGER(I-N)
43016       INTEGER PYK,PYCHGE,PYCOMP
43017 C...Commonblocks.
43018       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43019       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43020       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43021       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43022       COMMON/PYDAT4/CHAF(500,2)
43023       CHARACTER CHAF*16
43024       COMMON/PYDATR/MRPY(6),RRPY(100)
43025       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43026       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43027       COMMON/PYINT1/MINT(400),VINT(400)
43028       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43029       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43030       COMMON/PYINT4/MWID(500),WIDS(500,5)
43031       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
43032       COMMON/PYINT6/PROC(0:500)
43033       CHARACTER PROC*28
43034       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
43035       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
43036      &XPDIR(-6:6)
43037       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43038       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43039       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
43040      &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
43041      &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/
43042 C...Local arrays and character variables.
43043       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
43044      &CHNEW2*28,CHNAM*6,CHVAR(52)*6,CHALP(2)*26,CHIND*8,CHINI*10,
43045      &CHINR*16
43046       DIMENSION MSVAR(52,8)
43047
43048 C...For each variable to be translated give: name,
43049 C...integer/real/character, no. of indices, lower&upper index bounds.
43050       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
43051      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
43052      &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
43053      &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
43054      &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
43055      &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB'/
43056       DATA ((MSVAR(I,J),J=1,8),I=1,52)/ 1,7*0,  1,2,1,4000,1,5,2*0,
43057      &2,2,1,4000,1,5,2*0,  2,2,1,4000,1,5,2*0,  1,1,1,200,4*0,
43058      &2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
43059      &1,2,1,500,1,4,2*0,  2,2,1,500,1,4,2*0,  2,1,1,2000,4*0,
43060      &2,2,1,4,1,4,2*0,  1,2,1,500,1,3,2*0,  1,2,1,8000,1,2,2*0,
43061      &2,1,1,8000,4*0,  1,2,1,8000,1,5,2*0,  3,2,1,500,1,2,2*0,
43062      &1,1,1,6,4*0,  2,1,1,100,4*0,
43063      &1,7*0,  1,1,1,500,4*0,  1,2,1,2,-40,40,2*0,  2,1,1,200,4*0,
43064      &1,1,1,200,4*0,  2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
43065      &1,1,1,400,4*0,  2,1,1,400,4*0,  1,1,1,500,4*0,
43066      &1,2,1,500,1,2,2*0,  2,2,1,500,1,20,2*0,  1,3,1,40,1,4,1,2,
43067      &2,2,1,2,-40,40,2*0,  1,2,1,1000,1,3,2*0,  2,1,1,1000,4*0,
43068      &1,1,1,500,4*0,   2,2,1,500,1,5,2*0,   1,2,0,500,1,3,2*0,
43069      &2,2,0,500,1,3,2*0,   4,1,0,500,4*0,   2,3,0,6,0,6,0,5,
43070      &2,1,-6,6,4*0,     2,1,-6,6,4*0,    2,1,-6,6,4*0,
43071      &2,1,-6,6,4*0,  2,1,-6,6,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0,
43072      &2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3/
43073       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
43074      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
43075
43076 C...Length of character variable. Subdivide it into instructions.
43077       IF(MSTU(12).GE.1) CALL PYLIST(0)
43078       CHBIT=CHIN//' '
43079       LBIT=101
43080   100 LBIT=LBIT-1
43081       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
43082       LTOT=0
43083       DO 110 LCOM=1,LBIT
43084         IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
43085         LTOT=LTOT+1
43086         CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
43087   110 CONTINUE
43088       LLOW=0
43089   120 LHIG=LLOW+1
43090   130 LHIG=LHIG+1
43091       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
43092       LBIT=LHIG-LLOW-1
43093       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
43094
43095 C...Peel off any text following exclamation mark.
43096       LHIG2=LBIT
43097       DO 140 LLOW2=LHIG2,1,-1
43098         IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
43099   140 CONTINUE
43100       IF(LBIT.EQ.0) RETURN
43101
43102 C...Identify commonblock variable.
43103       LNAM=1
43104   150 LNAM=LNAM+1
43105       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
43106      &LNAM.LE.6) GOTO 150
43107       CHNAM=CHBIT(1:LNAM-1)//' '
43108       DO 170 LCOM=1,LNAM-1
43109         DO 160 LALP=1,26
43110           IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
43111      &    CHALP(2)(LALP:LALP)
43112   160   CONTINUE
43113   170 CONTINUE
43114       IVAR=0
43115       DO 180 IV=1,52
43116         IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
43117   180 CONTINUE
43118       IF(IVAR.EQ.0) THEN
43119         CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
43120         LLOW=LHIG
43121         IF(LLOW.LT.LTOT) GOTO 120
43122         RETURN
43123       ENDIF
43124
43125 C...Identify any indices.
43126       I1=0
43127       I2=0
43128       I3=0
43129       NINDX=0
43130       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
43131         LIND=LNAM
43132   190   LIND=LIND+1
43133         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
43134         CHIND=' '
43135         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
43136      &  .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
43137      &  IVAR.EQ.37)) THEN
43138           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
43139           READ(CHIND,'(I8)') KF
43140           I1=PYCOMP(KF)
43141         ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
43142      &    'c') THEN
43143           CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
43144      &    CHNAM)
43145           LLOW=LHIG
43146           IF(LLOW.LT.LTOT) GOTO 120
43147           RETURN
43148         ELSE
43149           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43150           READ(CHIND,'(I8)') I1
43151         ENDIF
43152         LNAM=LIND
43153         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43154         NINDX=1
43155       ENDIF
43156       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43157         LIND=LNAM
43158   200   LIND=LIND+1
43159         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
43160         CHIND=' '
43161         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43162         READ(CHIND,'(I8)') I2
43163         LNAM=LIND
43164         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43165         NINDX=2
43166       ENDIF
43167       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43168         LIND=LNAM
43169   210   LIND=LIND+1
43170         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
43171         CHIND=' '
43172         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43173         READ(CHIND,'(I8)') I3
43174         LNAM=LIND+1
43175         NINDX=3
43176       ENDIF
43177
43178 C...Check that indices allowed.
43179       IERR=0
43180       IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
43181       IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
43182      &IERR=2
43183       IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
43184      &IERR=3
43185       IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
43186      &IERR=4
43187       IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
43188       IF(IERR.GE.1) THEN
43189         CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
43190      &  CHBIT(1:LNAM-1))
43191         LLOW=LHIG
43192         IF(LLOW.LT.LTOT) GOTO 120
43193         RETURN
43194       ENDIF
43195
43196 C...Save old value of variable.
43197       IF(IVAR.EQ.1) THEN
43198         IOLD=N
43199       ELSEIF(IVAR.EQ.2) THEN
43200         IOLD=K(I1,I2)
43201       ELSEIF(IVAR.EQ.3) THEN
43202         ROLD=P(I1,I2)
43203       ELSEIF(IVAR.EQ.4) THEN
43204         ROLD=V(I1,I2)
43205       ELSEIF(IVAR.EQ.5) THEN
43206         IOLD=MSTU(I1)
43207       ELSEIF(IVAR.EQ.6) THEN
43208         ROLD=PARU(I1)
43209       ELSEIF(IVAR.EQ.7) THEN
43210         IOLD=MSTJ(I1)
43211       ELSEIF(IVAR.EQ.8) THEN
43212         ROLD=PARJ(I1)
43213       ELSEIF(IVAR.EQ.9) THEN
43214         IOLD=KCHG(I1,I2)
43215       ELSEIF(IVAR.EQ.10) THEN
43216         ROLD=PMAS(I1,I2)
43217       ELSEIF(IVAR.EQ.11) THEN
43218         ROLD=PARF(I1)
43219       ELSEIF(IVAR.EQ.12) THEN
43220         ROLD=VCKM(I1,I2)
43221       ELSEIF(IVAR.EQ.13) THEN
43222         IOLD=MDCY(I1,I2)
43223       ELSEIF(IVAR.EQ.14) THEN
43224         IOLD=MDME(I1,I2)
43225       ELSEIF(IVAR.EQ.15) THEN
43226         ROLD=BRAT(I1)
43227       ELSEIF(IVAR.EQ.16) THEN
43228         IOLD=KFDP(I1,I2)
43229       ELSEIF(IVAR.EQ.17) THEN
43230         CHOLD=CHAF(I1,I2)
43231       ELSEIF(IVAR.EQ.18) THEN
43232         IOLD=MRPY(I1)
43233       ELSEIF(IVAR.EQ.19) THEN
43234         ROLD=RRPY(I1)
43235       ELSEIF(IVAR.EQ.20) THEN
43236         IOLD=MSEL
43237       ELSEIF(IVAR.EQ.21) THEN
43238         IOLD=MSUB(I1)
43239       ELSEIF(IVAR.EQ.22) THEN
43240         IOLD=KFIN(I1,I2)
43241       ELSEIF(IVAR.EQ.23) THEN
43242         ROLD=CKIN(I1)
43243       ELSEIF(IVAR.EQ.24) THEN
43244         IOLD=MSTP(I1)
43245       ELSEIF(IVAR.EQ.25) THEN
43246         ROLD=PARP(I1)
43247       ELSEIF(IVAR.EQ.26) THEN
43248         IOLD=MSTI(I1)
43249       ELSEIF(IVAR.EQ.27) THEN
43250         ROLD=PARI(I1)
43251       ELSEIF(IVAR.EQ.28) THEN
43252         IOLD=MINT(I1)
43253       ELSEIF(IVAR.EQ.29) THEN
43254         ROLD=VINT(I1)
43255       ELSEIF(IVAR.EQ.30) THEN
43256         IOLD=ISET(I1)
43257       ELSEIF(IVAR.EQ.31) THEN
43258         IOLD=KFPR(I1,I2)
43259       ELSEIF(IVAR.EQ.32) THEN
43260         ROLD=COEF(I1,I2)
43261       ELSEIF(IVAR.EQ.33) THEN
43262         IOLD=ICOL(I1,I2,I3)
43263       ELSEIF(IVAR.EQ.34) THEN
43264         ROLD=XSFX(I1,I2)
43265       ELSEIF(IVAR.EQ.35) THEN
43266         IOLD=ISIG(I1,I2)
43267       ELSEIF(IVAR.EQ.36) THEN
43268         ROLD=SIGH(I1)
43269       ELSEIF(IVAR.EQ.37) THEN
43270         IOLD=MWID(I1)
43271       ELSEIF(IVAR.EQ.38) THEN
43272         ROLD=WIDS(I1,I2)
43273       ELSEIF(IVAR.EQ.39) THEN
43274         IOLD=NGEN(I1,I2)
43275       ELSEIF(IVAR.EQ.40) THEN
43276         ROLD=XSEC(I1,I2)
43277       ELSEIF(IVAR.EQ.41) THEN
43278         CHOLD2=PROC(I1)
43279       ELSEIF(IVAR.EQ.42) THEN
43280         ROLD=SIGT(I1,I2,I3)
43281       ELSEIF(IVAR.EQ.43) THEN
43282         ROLD=XPVMD(I1)
43283       ELSEIF(IVAR.EQ.44) THEN
43284         ROLD=XPANL(I1)
43285       ELSEIF(IVAR.EQ.45) THEN
43286         ROLD=XPANH(I1)
43287       ELSEIF(IVAR.EQ.46) THEN
43288         ROLD=XPBEH(I1)
43289       ELSEIF(IVAR.EQ.47) THEN
43290         ROLD=XPDIR(I1)
43291       ELSEIF(IVAR.EQ.48) THEN
43292         IOLD=IMSS(I1)
43293       ELSEIF(IVAR.EQ.49) THEN
43294         ROLD=RMSS(I1)
43295       ELSEIF(IVAR.EQ.50) THEN
43296         ROLD=RVLAM(I1,I2,I3)
43297       ELSEIF(IVAR.EQ.51) THEN
43298         ROLD=RVLAMP(I1,I2,I3)
43299       ELSEIF(IVAR.EQ.52) THEN
43300         ROLD=RVLAMB(I1,I2,I3)
43301       ENDIF
43302
43303 C...Print current value of variable. Loop back.
43304       IF(LNAM.GE.LBIT) THEN
43305         CHBIT(LNAM:14)=' '
43306         CHBIT(15:60)=' has the value                                '
43307         IF(MSVAR(IVAR,1).EQ.1) THEN
43308           WRITE(CHBIT(51:60),'(I10)') IOLD
43309         ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43310           WRITE(CHBIT(47:60),'(F14.5)') ROLD
43311         ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43312           CHBIT(53:60)=CHOLD
43313         ELSE
43314           CHBIT(33:60)=CHOLD
43315         ENDIF
43316         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43317         LLOW=LHIG
43318         IF(LLOW.LT.LTOT) GOTO 120
43319         RETURN
43320       ENDIF
43321
43322 C...Read in new variable value.
43323       IF(MSVAR(IVAR,1).EQ.1) THEN
43324         CHINI=' '
43325         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
43326         READ(CHINI,'(I10)') INEW
43327       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43328         CHINR=' '
43329         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
43330         READ(CHINR,*) RNEW
43331       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43332         CHNEW=CHBIT(LNAM+1:LBIT)//' '
43333       ELSE
43334         CHNEW2=CHBIT(LNAM+1:LBIT)//' '
43335       ENDIF
43336
43337 C...Store new variable value.
43338       IF(IVAR.EQ.1) THEN
43339         N=INEW
43340       ELSEIF(IVAR.EQ.2) THEN
43341         K(I1,I2)=INEW
43342       ELSEIF(IVAR.EQ.3) THEN
43343         P(I1,I2)=RNEW
43344       ELSEIF(IVAR.EQ.4) THEN
43345         V(I1,I2)=RNEW
43346       ELSEIF(IVAR.EQ.5) THEN
43347         MSTU(I1)=INEW
43348       ELSEIF(IVAR.EQ.6) THEN
43349         PARU(I1)=RNEW
43350       ELSEIF(IVAR.EQ.7) THEN
43351         MSTJ(I1)=INEW
43352       ELSEIF(IVAR.EQ.8) THEN
43353         PARJ(I1)=RNEW
43354       ELSEIF(IVAR.EQ.9) THEN
43355         KCHG(I1,I2)=INEW
43356       ELSEIF(IVAR.EQ.10) THEN
43357         PMAS(I1,I2)=RNEW
43358       ELSEIF(IVAR.EQ.11) THEN
43359         PARF(I1)=RNEW
43360       ELSEIF(IVAR.EQ.12) THEN
43361         VCKM(I1,I2)=RNEW
43362       ELSEIF(IVAR.EQ.13) THEN
43363         MDCY(I1,I2)=INEW
43364       ELSEIF(IVAR.EQ.14) THEN
43365         MDME(I1,I2)=INEW
43366       ELSEIF(IVAR.EQ.15) THEN
43367         BRAT(I1)=RNEW
43368       ELSEIF(IVAR.EQ.16) THEN
43369         KFDP(I1,I2)=INEW
43370       ELSEIF(IVAR.EQ.17) THEN
43371         CHAF(I1,I2)=CHNEW
43372       ELSEIF(IVAR.EQ.18) THEN
43373         MRPY(I1)=INEW
43374       ELSEIF(IVAR.EQ.19) THEN
43375         RRPY(I1)=RNEW
43376       ELSEIF(IVAR.EQ.20) THEN
43377         MSEL=INEW
43378       ELSEIF(IVAR.EQ.21) THEN
43379         MSUB(I1)=INEW
43380       ELSEIF(IVAR.EQ.22) THEN
43381         KFIN(I1,I2)=INEW
43382       ELSEIF(IVAR.EQ.23) THEN
43383         CKIN(I1)=RNEW
43384       ELSEIF(IVAR.EQ.24) THEN
43385         MSTP(I1)=INEW
43386       ELSEIF(IVAR.EQ.25) THEN
43387         PARP(I1)=RNEW
43388       ELSEIF(IVAR.EQ.26) THEN
43389         MSTI(I1)=INEW
43390       ELSEIF(IVAR.EQ.27) THEN
43391         PARI(I1)=RNEW
43392       ELSEIF(IVAR.EQ.28) THEN
43393         MINT(I1)=INEW
43394       ELSEIF(IVAR.EQ.29) THEN
43395         VINT(I1)=RNEW
43396       ELSEIF(IVAR.EQ.30) THEN
43397         ISET(I1)=INEW
43398       ELSEIF(IVAR.EQ.31) THEN
43399         KFPR(I1,I2)=INEW
43400       ELSEIF(IVAR.EQ.32) THEN
43401         COEF(I1,I2)=RNEW
43402       ELSEIF(IVAR.EQ.33) THEN
43403         ICOL(I1,I2,I3)=INEW
43404       ELSEIF(IVAR.EQ.34) THEN
43405         XSFX(I1,I2)=RNEW
43406       ELSEIF(IVAR.EQ.35) THEN
43407         ISIG(I1,I2)=INEW
43408       ELSEIF(IVAR.EQ.36) THEN
43409         SIGH(I1)=RNEW
43410       ELSEIF(IVAR.EQ.37) THEN
43411         MWID(I1)=INEW
43412       ELSEIF(IVAR.EQ.38) THEN
43413         WIDS(I1,I2)=RNEW
43414       ELSEIF(IVAR.EQ.39) THEN
43415         NGEN(I1,I2)=INEW
43416       ELSEIF(IVAR.EQ.40) THEN
43417         XSEC(I1,I2)=RNEW
43418       ELSEIF(IVAR.EQ.41) THEN
43419         PROC(I1)=CHNEW2
43420       ELSEIF(IVAR.EQ.42) THEN
43421         SIGT(I1,I2,I3)=RNEW
43422       ELSEIF(IVAR.EQ.43) THEN
43423         XPVMD(I1)=RNEW
43424       ELSEIF(IVAR.EQ.44) THEN
43425         XPANL(I1)=RNEW
43426       ELSEIF(IVAR.EQ.45) THEN
43427         XPANH(I1)=RNEW
43428       ELSEIF(IVAR.EQ.46) THEN
43429         XPBEH(I1)=RNEW
43430       ELSEIF(IVAR.EQ.47) THEN
43431         XPDIR(I1)=RNEW
43432       ELSEIF(IVAR.EQ.48) THEN
43433         IMSS(I1)=INEW
43434       ELSEIF(IVAR.EQ.49) THEN
43435         RMSS(I1)=RNEW
43436       ELSEIF(IVAR.EQ.50) THEN
43437         RVLAM(I1,I2,I3)=RNEW
43438       ELSEIF(IVAR.EQ.51) THEN
43439         RVLAMP(I1,I2,I3)=RNEW
43440       ELSEIF(IVAR.EQ.52) THEN
43441         RVLAMB(I1,I2,I3)=RNEW
43442       ENDIF
43443
43444 C...Write old and new value. Loop back.
43445       CHBIT(LNAM:14)=' '
43446       CHBIT(15:60)=' changed from                to               '
43447       IF(MSVAR(IVAR,1).EQ.1) THEN
43448         WRITE(CHBIT(33:42),'(I10)') IOLD
43449         WRITE(CHBIT(51:60),'(I10)') INEW
43450         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43451       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43452         WRITE(CHBIT(29:42),'(F14.5)') ROLD
43453         WRITE(CHBIT(47:60),'(F14.5)') RNEW
43454         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43455       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43456         CHBIT(35:42)=CHOLD
43457         CHBIT(53:60)=CHNEW
43458         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43459       ELSE
43460         CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
43461         IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
43462       ENDIF
43463       LLOW=LHIG
43464       IF(LLOW.LT.LTOT) GOTO 120
43465
43466 C...Format statement for output on unit MSTU(11) (by default 6).
43467  5000 FORMAT(5X,A60)
43468  5100 FORMAT(5X,A88)
43469
43470       RETURN
43471       END
43472
43473 C*********************************************************************
43474
43475 C...PYEXEC
43476 C...Administrates the fragmentation and decay chain.
43477
43478       SUBROUTINE PYEXEC
43479
43480 C...Double precision and integer declarations.
43481       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43482       IMPLICIT INTEGER(I-N)
43483       INTEGER PYK,PYCHGE,PYCOMP
43484 C...Commonblocks.
43485       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43486       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43487       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43488       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43489       COMMON/PYINT4/MWID(500),WIDS(500,5)
43490       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
43491 C...Local array.
43492       DIMENSION PS(2,6),IJOIN(100)
43493
43494 C...Initialize and reset.
43495       MSTU(24)=0
43496       IF(MSTU(12).GE.1) CALL PYLIST(0)
43497       MSTU(31)=MSTU(31)+1
43498       MSTU(1)=0
43499       MSTU(2)=0
43500       MSTU(3)=0
43501       IF(MSTU(17).LE.0) MSTU(90)=0
43502       MCONS=1
43503
43504 C...Sum up momentum, energy and charge for starting entries.
43505       NSAV=N
43506       DO 110 I=1,2
43507         DO 100 J=1,6
43508           PS(I,J)=0D0
43509   100   CONTINUE
43510   110 CONTINUE
43511       DO 130 I=1,N
43512         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
43513         DO 120 J=1,4
43514           PS(1,J)=PS(1,J)+P(I,J)
43515   120   CONTINUE
43516         PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
43517   130 CONTINUE
43518       PARU(21)=PS(1,4)
43519
43520 C...Prepare system for subsequent fragmentation/decay.
43521       CALL PYPREP(0)
43522
43523 C...Loop through jet fragmentation and particle decays.
43524       MBE=0
43525   140 MBE=MBE+1
43526       IP=0
43527   150 IP=IP+1
43528       KC=0
43529       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
43530       IF(KC.EQ.0) THEN
43531
43532 C...Deal with any remaining undecayed resonance
43533 C...(normally the task of PYEVNT, so seldom used).
43534       ELSEIF(MWID(KC).NE.0) THEN
43535         IBEG=IP
43536         IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
43537           IBEG=IP+1
43538   160     IBEG=IBEG-1
43539           IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
43540           IF(K(IBEG,1).NE.2) IBEG=IBEG+1
43541           IEND=IP-1
43542   170     IEND=IEND+1
43543           IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
43544           IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
43545           NJOIN=0
43546           DO 180 I=IBEG,IEND
43547             IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
43548               NJOIN=NJOIN+1
43549               IJOIN(NJOIN)=I
43550             ENDIF
43551   180     CONTINUE
43552         ENDIF
43553         CALL PYRESD(IP)
43554         CALL PYPREP(IBEG)
43555
43556 C...Particle decay if unstable and allowed. Save long-lived particle
43557 C...decays until second pass after Bose-Einstein effects.
43558       ELSEIF(KCHG(KC,2).EQ.0) THEN
43559         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
43560      &  .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
43561      &  CALL PYDECY(IP)
43562
43563 C...Decay products may develop a shower.
43564         IF(MSTJ(92).GT.0) THEN
43565           IP1=MSTJ(92)
43566           QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
43567      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
43568           CALL PYSHOW(IP1,IP1+1,QMAX)
43569           CALL PYPREP(IP1)
43570           MSTJ(92)=0
43571         ELSEIF(MSTJ(92).LT.0) THEN
43572           IP1=-MSTJ(92)
43573           CALL PYSHOW(IP1,-3,P(IP,5))
43574           CALL PYPREP(IP1)
43575           MSTJ(92)=0
43576         ENDIF
43577
43578 C...Jet fragmentation: string or independent fragmentation.
43579       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
43580         MFRAG=MSTJ(1)
43581         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
43582         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
43583           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
43584      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
43585             IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
43586           ENDIF
43587         ENDIF
43588         IF(MFRAG.EQ.1) CALL PYSTRF(IP)
43589         IF(MFRAG.EQ.2) CALL PYINDF(IP)
43590         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
43591         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
43592       ENDIF
43593
43594 C...Loop back if enough space left in PYJETS and no error abort.
43595       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
43596       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
43597         GOTO 150
43598       ELSEIF(IP.LT.N) THEN
43599         CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
43600       ENDIF
43601
43602 C...Include simple Bose-Einstein effect parametrization if desired.
43603       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
43604         CALL PYBOEI(NSAV)
43605         GOTO 140
43606       ENDIF
43607
43608 C...Check that momentum, energy and charge were conserved.
43609       DO 200 I=1,N
43610         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
43611         DO 190 J=1,4
43612           PS(2,J)=PS(2,J)+P(I,J)
43613   190   CONTINUE
43614         PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
43615   200 CONTINUE
43616       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
43617      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
43618       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
43619      &'(PYEXEC:) four-momentum was not conserved')
43620       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
43621      &'(PYEXEC:) charge was not conserved')
43622
43623       RETURN
43624       END
43625
43626 C*********************************************************************
43627
43628 C...PYPREP
43629 C...Rearranges partons along strings.
43630 C...Allows small systems to collapse into one or two particles.
43631 C...Checks flavours and colour singlet invarient masses.
43632
43633       SUBROUTINE PYPREP(IP)
43634
43635 C...Double precision and integer declarations.
43636       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43637       INTEGER PYK,PYCHGE,PYCOMP
43638 C...Commonblocks.
43639       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43640       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43641       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43642       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43643       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
43644 C...Local arrays.
43645       DIMENSION DPS(5),DPC(5),UE(3),PG(5),
43646      &E1(3),E2(3),E3(3),E4(3),ECL(3)
43647
43648 C...Function to give four-product.
43649       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)
43650
43651 C...Rearrange parton shower product listing along strings: begin loop.
43652       I1=N
43653       DO 130 MQGST=1,2
43654         DO 120 I=MAX(1,IP),N
43655           IF(K(I,1).NE.3) GOTO 120
43656           KC=PYCOMP(K(I,2))
43657           IF(KC.EQ.0) GOTO 120
43658           KQ=KCHG(KC,2)
43659           IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
43660
43661 C...Pick up loose string end.
43662           KCS=4
43663           IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
43664           IA=I
43665           NSTP=0
43666   100     NSTP=NSTP+1
43667           IF(NSTP.GT.4*N) THEN
43668             CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
43669             RETURN
43670           ENDIF
43671
43672 C...Copy undecayed parton.
43673           IF(K(IA,1).EQ.3) THEN
43674             IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
43675               CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
43676               RETURN
43677             ENDIF
43678             I1=I1+1
43679             K(I1,1)=2
43680             IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
43681             K(I1,2)=K(IA,2)
43682             K(I1,3)=IA
43683             K(I1,4)=0
43684             K(I1,5)=0
43685             DO 110 J=1,5
43686               P(I1,J)=P(IA,J)
43687               V(I1,J)=V(IA,J)
43688   110       CONTINUE
43689             K(IA,1)=K(IA,1)+10
43690             IF(K(I1,1).EQ.1) GOTO 120
43691           ENDIF
43692
43693 C...GOTO next parton in colour space.
43694           IB=IA
43695           IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
43696      &    .NE.0) THEN
43697             IA=MOD(K(IB,KCS),MSTU(5))
43698             K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
43699             MREV=0
43700           ELSE
43701             IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
43702      &      MSTU(5)).EQ.0) KCS=9-KCS
43703             IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
43704             K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
43705             MREV=1
43706           ENDIF
43707           IF(IA.LE.0.OR.IA.GT.N) THEN
43708             CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
43709             RETURN
43710           ENDIF
43711           IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
43712      &    MSTU(5)).EQ.IB) THEN
43713             IF(MREV.EQ.1) KCS=9-KCS
43714             IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
43715             K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
43716           ELSE
43717             IF(MREV.EQ.0) KCS=9-KCS
43718             IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
43719             K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
43720           ENDIF
43721           IF(IA.NE.I) GOTO 100
43722           K(I1,1)=1
43723   120   CONTINUE
43724   130 CONTINUE
43725       N=I1
43726
43727 C...Done if no checks on small-mass systems.
43728       IF(MSTJ(14).LT.0) RETURN
43729       IF(MSTJ(14).EQ.0) GOTO 540
43730
43731 C...Find lowest-mass colour singlet jet system.
43732       NS=N
43733   140 NSIN=N-NS
43734       PDMIN=1D0+PARJ(32)
43735       IC=0
43736       DO 190 I=MAX(1,IP),N
43737         IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
43738         ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
43739           NSIN=NSIN+1
43740           IC=I
43741           DO 150 J=1,4
43742             DPS(J)=P(I,J)
43743   150     CONTINUE
43744           MSTJ(93)=1
43745           DPS(5)=PYMASS(K(I,2))
43746         ELSEIF(K(I,1).EQ.2) THEN
43747           DO 160 J=1,4
43748             DPS(J)=DPS(J)+P(I,J)
43749   160     CONTINUE
43750         ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43751           DO 170 J=1,4
43752             DPS(J)=DPS(J)+P(I,J)
43753   170     CONTINUE
43754           MSTJ(93)=1
43755           DPS(5)=DPS(5)+PYMASS(K(I,2))
43756           PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
43757      &    DPS(5)
43758           IF(PD.LT.PDMIN) THEN
43759             PDMIN=PD
43760             DO 180 J=1,5
43761               DPC(J)=DPS(J)
43762   180       CONTINUE
43763             IC1=IC
43764             IC2=I
43765           ENDIF
43766           IC=0
43767         ELSE
43768           NSIN=NSIN+1
43769         ENDIF
43770   190 CONTINUE
43771
43772 C...Done if lowest-mass system above threshold for string frag.
43773       IF(PDMIN.GE.PARJ(32)) GOTO 540
43774
43775 C...Fill small-mass system as cluster.
43776       NSAV=N
43777       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
43778       K(N+1,1)=11
43779       K(N+1,2)=91
43780       K(N+1,3)=IC1
43781       P(N+1,1)=DPC(1)
43782       P(N+1,2)=DPC(2)
43783       P(N+1,3)=DPC(3)
43784       P(N+1,4)=DPC(4)
43785       P(N+1,5)=PECM
43786
43787 C...Set up history, assuming cluster -> 2 hadrons.
43788       NBODY=2
43789       K(N+1,4)=N+2
43790       K(N+1,5)=N+3
43791       K(N+2,1)=1
43792       K(N+3,1)=1
43793       IF(MSTU(16).NE.2) THEN
43794         K(N+2,3)=N+1
43795         K(N+3,3)=N+1
43796       ELSE
43797         K(N+2,3)=IC1
43798         K(N+3,3)=IC2
43799       ENDIF
43800       K(N+2,4)=0
43801       K(N+3,4)=0
43802       K(N+2,5)=0
43803       K(N+3,5)=0
43804       V(N+1,5)=0D0
43805       V(N+2,5)=0D0
43806       V(N+3,5)=0D0
43807
43808 C...Form two particles from flavours of lowest-mass system, if feasible.
43809       NTRY = 0
43810   200 NTRY = NTRY + 1
43811 C...Open string.
43812       IF(IABS(K(IC1,2)).NE.21) THEN
43813         KC1=PYCOMP(K(IC1,2))
43814         KC2=PYCOMP(K(IC2,2))
43815         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 540
43816         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
43817         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
43818         IF(KQ1+KQ2.NE.0) GOTO 540
43819 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
43820   210   K1=K(IC1,2)
43821         IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
43822         MSTU(125)=0
43823         CALL PYDCYK(K1,0,KFLN,K(N+2,2))
43824         CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
43825         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
43826 C...Closed string.
43827       ELSE
43828         IF(IABS(K(IC2,2)).NE.21) GOTO 540
43829 C...No room for popcorn mesons in closed string -> 2 hadrons.
43830         MSTU(125)=0
43831   220   CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
43832         CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
43833         CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
43834         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
43835       ENDIF
43836       P(N+2,5)=PYMASS(K(N+2,2))
43837       P(N+3,5)=PYMASS(K(N+3,2))
43838
43839 C...If it does not work: try again (a number of times), give up
43840 C...(if no place to shuffle momentum), or form one hadron.
43841       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
43842         IF(NTRY.LT.MSTJ(17)) THEN
43843           GOTO 200
43844         ELSEIF(NSIN.EQ.1) THEN
43845           GOTO 540
43846         ELSE
43847           GOTO 290
43848         END IF
43849       END IF
43850
43851 C...Perform two-particle decay of jet system.
43852 C...First step: find reference axis in decaying system rest frame.
43853 C...(Borrow slot N+2 for temporary direction.)
43854       DO 230 J=1,4
43855         P(N+2,J)=P(IC1,J)
43856   230 CONTINUE
43857       DO 250 I=IC1+1,IC2-1
43858         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
43859      &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43860           FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
43861           DO 240 J=1,4
43862             P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
43863   240     CONTINUE
43864         ENDIF
43865   250 CONTINUE
43866       CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
43867      &-DPC(3)/DPC(4))
43868       THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
43869       PHI1=PYANGL(P(N+2,1),P(N+2,2))
43870
43871 C...Second step: generate isotropic/anisotropic decay.
43872       PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
43873      &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
43874   260 UE(3)=PYR(0)
43875       PT2=(1D0-UE(3)**2)*PA**2
43876       IF(MSTJ(16).LE.0) THEN
43877         PREV=0.5D0
43878       ELSE
43879         IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
43880         PR1=P(N+2,5)**2+PT2
43881         PR2=P(N+3,5)**2+PT2
43882         ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
43883         PREVCF=PARJ(42)
43884         IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
43885         PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
43886       ENDIF
43887       IF(PYR(0).LT.PREV) UE(3)=-UE(3)
43888       PHI=PARU(2)*PYR(0)
43889       UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
43890       UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
43891       DO 270 J=1,3
43892         P(N+2,J)=PA*UE(J)
43893         P(N+3,J)=-PA*UE(J)
43894   270 CONTINUE
43895       P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
43896       P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
43897
43898 C...Third step: move back to event frame and set production vertex.
43899       CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
43900      &DPC(3)/DPC(4))
43901       DO 280 J=1,4
43902         V(N+1,J)=V(IC1,J)
43903         V(N+2,J)=V(IC1,J)
43904         V(N+3,J)=V(IC2,J)
43905   280 CONTINUE
43906       N=N+3
43907       GOTO 520
43908
43909 C...Else form one particle, if possible.
43910   290 NBODY=1
43911       K(N+1,5)=N+2
43912       DO 300 J=1,4
43913         V(N+1,J)=V(IC1,J)
43914         V(N+2,J)=V(IC1,J)
43915   300 CONTINUE
43916
43917 C...Select hadron flavour from available quark flavours.
43918   310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
43919         GOTO 540
43920       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
43921         CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
43922       ELSE
43923         KFLN=1+INT((2D0+PARJ(2))*PYR(0))
43924         CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
43925       ENDIF
43926       IF(K(N+2,2).EQ.0) GOTO 310
43927       P(N+2,5)=PYMASS(K(N+2,2))
43928
43929 C...Use old algorithm for E/p conservation? (EN)
43930       IF (MSTJ(16).LE.0) GOTO 480
43931
43932 C...Find the string piece closest to the cluster by a loop
43933 C...over the undecayed partons not in present cluster. (EN)
43934       DGLOMI=1D30
43935       IBEG=0
43936       I0=0
43937       DO 340 I1=MAX(1,IP),N-1
43938         IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
43939           I0=0
43940         ELSEIF(K(I1,1).EQ.2) THEN
43941           IF(I0.EQ.0) I0=I1
43942           I2=I1
43943   320     I2=I2+1
43944           IF(K(I2,1).GT.10) GOTO 320
43945           IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
43946
43947 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
43948           DO 330 J=1,3
43949             E1(J)=P(I1,J)/P(I1,4)
43950             E2(J)=P(I2,J)/P(I2,4)
43951             ECL(J)=P(N+1,J)/P(N+1,4)
43952             E3(J)=E2(J)-E1(J)
43953             E4(J)=ECL(J)-E1(J)
43954   330     CONTINUE
43955
43956 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
43957           E3S=E3(1)**2+E3(2)**2+E3(3)**2
43958           E4S=E4(1)**2+E4(2)**2+E4(3)**2
43959           E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
43960           IF(E34.LE.0D0) THEN
43961             DDMIN=E4S
43962           ELSEIF(E34.LT.E3S) THEN
43963             DDMIN=E4S-E34**2/E3S
43964           ELSE
43965             DDMIN=E4S-2D0*E34+E3S
43966           ENDIF
43967
43968 C...Is this the smallest so far?
43969           IF(DDMIN.LT.DGLOMI) THEN
43970             DGLOMI=DDMIN
43971             IBEG=I0
43972             IPCS=I1
43973           ENDIF
43974         ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
43975           I0=0
43976         ENDIF
43977   340 CONTINUE
43978
43979 C... Check if there are any strings to connect to the new gluon. (EN)
43980       IF (IBEG.EQ.0) GOTO 480
43981
43982 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
43983       IF (P(N+1,5).GE.P(N+2,5)) THEN
43984
43985 C...Construct 'gluon' that is needed to put hadron on the mass shell.
43986         FRAC=P(N+2,5)/P(N+1,5)
43987         DO 350 J=1,5
43988           P(N+2,J)=FRAC*P(N+1,J)
43989           PG(J)=(1D0-FRAC)*P(N+1,J)
43990   350   CONTINUE
43991
43992 C... Copy string with new gluon put in.
43993         N=N+2
43994         I=IBEG-1
43995   360   I=I+1
43996         IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
43997         IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
43998         N=N+1
43999         DO 370 J=1,5
44000           K(N,J)=K(I,J)
44001           P(N,J)=P(I,J)
44002           V(N,J)=V(I,J)
44003   370   CONTINUE
44004         K(I,1)=K(I,1)+10
44005         K(I,4)=N
44006         K(I,5)=N
44007         K(N,3)=I
44008         IF(I.EQ.IPCS) THEN
44009           N=N+1
44010           DO 380 J=1,5
44011             K(N,J)=K(N-1,J)
44012             P(N,J)=PG(J)
44013             V(N,J)=V(N-1,J)
44014   380     CONTINUE
44015           K(N,2)=21
44016           K(N,3)=NSAV+1
44017         ENDIF
44018         IF(K(I,1).EQ.12) GOTO 360
44019         GOTO 520
44020
44021 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
44022 C...from string piece endpoints.
44023       ELSE
44024
44025 C...Begin by copying string that should give energy to cluster.
44026         N=N+2
44027         I=IBEG-1
44028   390   I=I+1
44029         IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
44030         IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
44031         N=N+1
44032         DO 400 J=1,5
44033           K(N,J)=K(I,J)
44034           P(N,J)=P(I,J)
44035           V(N,J)=V(I,J)
44036   400   CONTINUE
44037         K(I,1)=K(I,1)+10
44038         K(I,4)=N
44039         K(I,5)=N
44040         K(N,3)=I
44041         IF(I.EQ.IPCS) I1=N
44042         IF(K(I,1).EQ.12) GOTO 390
44043         I2=I1+1
44044
44045 C...Set initial Phad.
44046         DO 410 J=1,4
44047           P(NSAV+2,J)=P(NSAV+1,J)
44048   410   CONTINUE
44049
44050 C...Calculate Pg, a part of which will be added to Phad later. (EN)
44051   420   IF(MSTJ(16).EQ.1) THEN
44052           ALPHA=1D0
44053           BETA=1D0
44054         ELSE
44055           ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
44056           BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
44057         ENDIF
44058         DO 430 J=1,4
44059           PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
44060   430   CONTINUE
44061         PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
44062
44063 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
44064         PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
44065      &  P(NSAV+2,3)**2
44066         PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
44067      &  P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
44068         DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
44069
44070 C...If all gluon energy eaten, zero it and take a step back.
44071         ITER=0
44072         IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
44073           ITER=1
44074           DO 440 J=1,4
44075             P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
44076             P(I1,J)=0D0
44077   440     CONTINUE
44078           P(I1,5)=0D0
44079           K(I1,1)=K(I1,1)+10
44080           I1=I1-1
44081         ENDIF
44082         IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
44083           ITER=1
44084           DO 450 J=1,4
44085             P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
44086             P(I2,J)=0D0
44087   450     CONTINUE
44088           P(I2,5)=0D0
44089           K(I2,1)=K(I2,1)+10
44090           I2=I2+1
44091         ENDIF
44092         IF(ITER.EQ.1) GOTO 420
44093
44094 C...If also all endpoint energy eaten, revert to old procedure.
44095         IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
44096      &  (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
44097           DO 460 I=NSAV+3,N
44098             IM=K(I,3)
44099             K(IM,1)=K(IM,1)-10
44100             K(IM,4)=0
44101             K(IM,5)=0
44102   460     CONTINUE
44103           N=NSAV
44104           GOTO 480
44105         ENDIF
44106
44107 C... Construct the collapsed hadron and modified string partons.
44108         DO 470 J=1,4
44109           P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
44110           P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
44111           P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
44112   470   CONTINUE
44113           P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
44114           P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
44115
44116 C...Finished with string collapse in new scheme.
44117         GOTO 520
44118       ENDIF
44119
44120 C... Use old algorithm; by choice or when in trouble.
44121   480 CONTINUE
44122 C...Find parton/particle which combines to largest extra mass.
44123       IR=0
44124       HA=0D0
44125       HSM=0D0
44126       DO 500 MCOMB=1,3
44127         IF(IR.NE.0) GOTO 500
44128         DO 490 I=MAX(1,IP),N
44129           IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
44130      &    .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 490
44131           IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
44132           IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
44133           IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
44134           IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
44135      &    GOTO 490
44136           HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
44137           HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
44138           IF(HSR.GT.HSM) THEN
44139             IR=I
44140             HA=HCR
44141             HSM=HSR
44142           ENDIF
44143   490   CONTINUE
44144   500 CONTINUE
44145
44146 C...Shuffle energy and momentum to put new particle on mass shell.
44147       IF(IR.NE.0) THEN
44148         HB=PECM**2+HA
44149         HC=P(N+2,5)**2+HA
44150         HD=P(IR,5)**2+HA
44151         HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
44152      &  (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
44153         HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
44154         DO 510 J=1,4
44155           P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
44156           P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
44157   510   CONTINUE
44158         N=N+2
44159       ELSE
44160         CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
44161         RETURN
44162       ENDIF
44163
44164 C...Mark collapsed system and store daughter pointers. Iterate.
44165   520 DO 530 I=IC1,IC2
44166         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
44167      &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
44168           K(I,1)=K(I,1)+10
44169           IF(MSTU(16).NE.2) THEN
44170             K(I,4)=NSAV+1
44171             K(I,5)=NSAV+1
44172           ELSE
44173             K(I,4)=NSAV+2
44174             K(I,5)=NSAV+1+NBODY
44175           ENDIF
44176         ENDIF
44177   530 CONTINUE
44178       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
44179
44180 C...Check flavours and invariant masses in parton systems.
44181   540 NP=0
44182       KFN=0
44183       KQS=0
44184       DO 550 J=1,5
44185         DPS(J)=0D0
44186   550 CONTINUE
44187       DO 580 I=MAX(1,IP),N
44188         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
44189         KC=PYCOMP(K(I,2))
44190         IF(KC.EQ.0) GOTO 580
44191         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44192         IF(KQ.EQ.0) GOTO 580
44193         NP=NP+1
44194         IF(KQ.NE.2) THEN
44195           KFN=KFN+1
44196           KQS=KQS+KQ
44197           MSTJ(93)=1
44198           DPS(5)=DPS(5)+PYMASS(K(I,2))
44199         ENDIF
44200         DO 560 J=1,4
44201           DPS(J)=DPS(J)+P(I,J)
44202   560   CONTINUE
44203         IF(K(I,1).EQ.1) THEN
44204           IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
44205      &    PYERRM(2,'(PYPREP:) unphysical flavour combination')
44206           IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
44207      &    (0.9D0*PARJ(32)+DPS(5))**2) THEN
44208             CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
44209           END IF
44210           NP=0
44211           KFN=0
44212           KQS=0
44213           DO 570 J=1,5
44214             DPS(J)=0D0
44215   570     CONTINUE
44216         ENDIF
44217   580 CONTINUE
44218
44219       RETURN
44220       END
44221
44222 C*********************************************************************
44223
44224 C...PYSTRF
44225 C...Handles the fragmentation of an arbitrary colour singlet
44226 C...jet system according to the Lund string fragmentation model.
44227
44228       SUBROUTINE PYSTRF(IP)
44229
44230 C...Double precision and integer declarations.
44231       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44232       IMPLICIT INTEGER(I-N)
44233       INTEGER PYK,PYCHGE,PYCOMP
44234 C...Commonblocks.
44235       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44236       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44237       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44238       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44239 C...Local arrays. All MOPS variables ends with MO
44240       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
44241      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
44242      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
44243      &INMO(9),PM2QMO(2),XTMO(2)
44244
44245 C...Function: four-product of two vectors.
44246       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)
44247       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
44248      &DP(I,3)*DP(J,3)
44249
44250 C...Reset counters. Identify parton system.
44251       MSTJ(91)=0
44252       NSAV=N
44253       MSTU90=MSTU(90)
44254       NP=0
44255       KQSUM=0
44256       DO 100 J=1,5
44257         DPS(J)=0D0
44258   100 CONTINUE
44259       MJU(1)=0
44260       MJU(2)=0
44261       I=IP-1
44262   110 I=I+1
44263       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
44264         CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
44265         IF(MSTU(21).GE.1) RETURN
44266       ENDIF
44267       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
44268       KC=PYCOMP(K(I,2))
44269       IF(KC.EQ.0) GOTO 110
44270       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44271       IF(KQ.EQ.0) GOTO 110
44272       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
44273         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44274         IF(MSTU(21).GE.1) RETURN
44275       ENDIF
44276
44277 C...Take copy of partons to be considered. Check flavour sum.
44278       NP=NP+1
44279       DO 120 J=1,5
44280         K(N+NP,J)=K(I,J)
44281         P(N+NP,J)=P(I,J)
44282         IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
44283   120 CONTINUE
44284       DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
44285       K(N+NP,3)=I
44286       IF(KQ.NE.2) KQSUM=KQSUM+KQ
44287       IF(K(I,1).EQ.41) THEN
44288         KQSUM=KQSUM+2*KQ
44289         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
44290         IF(KQSUM.NE.KQ) MJU(2)=N+NP
44291       ENDIF
44292       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
44293       IF(KQSUM.NE.0) THEN
44294         CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44295         IF(MSTU(21).GE.1) RETURN
44296       ENDIF
44297
44298 C...Boost copied system to CM frame (for better numerical precision).
44299       IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
44300         MBST=0
44301         MSTU(33)=1
44302         CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
44303      &  -DPS(3)/DPS(4))
44304       ELSE
44305         MBST=1
44306         HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
44307         DO 130 I=N+1,N+NP
44308           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
44309           IF(P(I,3).GT.0D0) THEN
44310             HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
44311             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
44312             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44313           ELSE
44314             HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
44315             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
44316             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44317           ENDIF
44318   130   CONTINUE
44319       ENDIF
44320
44321 C...Search for very nearby partons that may be recombined.
44322       NTRYR=0
44323       PARU12=PARU(12)
44324       PARU13=PARU(13)
44325       MJU(3)=MJU(1)
44326       MJU(4)=MJU(2)
44327       NR=NP
44328   140 IF(NR.GE.3) THEN
44329         PDRMIN=2D0*PARU12
44330         DO 150 I=N+1,N+NR
44331           IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
44332           I1=I+1
44333           IF(I.EQ.N+NR) I1=N+1
44334           IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
44335           IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
44336      &    GOTO 150
44337           IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
44338      &    GOTO 150
44339           PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
44340      &    P(I1,2)**2+P(I1,3)**2))
44341           PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
44342           PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
44343           IF(PDR.LT.PDRMIN) THEN
44344             IR=I
44345             PDRMIN=PDR
44346           ENDIF
44347   150   CONTINUE
44348
44349 C...Recombine very nearby partons to avoid machine precision problems.
44350         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
44351           DO 160 J=1,4
44352             P(N+1,J)=P(N+1,J)+P(N+NR,J)
44353   160     CONTINUE
44354           P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44355      &    P(N+1,3)**2))
44356           NR=NR-1
44357           GOTO 140
44358         ELSEIF(PDRMIN.LT.PARU12) THEN
44359           DO 170 J=1,4
44360             P(IR,J)=P(IR,J)+P(IR+1,J)
44361   170     CONTINUE
44362           P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
44363      &    P(IR,3)**2))
44364           DO 190 I=IR+1,N+NR-1
44365             K(I,2)=K(I+1,2)
44366             DO 180 J=1,5
44367               P(I,J)=P(I+1,J)
44368   180       CONTINUE
44369   190     CONTINUE
44370           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
44371           NR=NR-1
44372           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
44373           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
44374           GOTO 140
44375         ENDIF
44376       ENDIF
44377       NTRYR=NTRYR+1
44378
44379 C...Reset particle counter. Skip ahead if no junctions are present;
44380 C...this is usually the case!
44381       NRS=MAX(5*NR+11,NP)
44382       NTRY=0
44383   200 NTRY=NTRY+1
44384       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44385         PARU12=4D0*PARU12
44386         PARU13=2D0*PARU13
44387         GOTO 140
44388       ELSEIF(NTRY.GT.100) THEN
44389         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44390         IF(MSTU(21).GE.1) RETURN
44391       ENDIF
44392       I=N+NRS
44393       MSTU(90)=MSTU90
44394       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
44395       IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
44396      &     ' junction strings not handled by MSTJ(12)>3 options')
44397       DO 570 JT=1,2
44398         NJS(JT)=0
44399         IF(MJU(JT).EQ.0) GOTO 570
44400         JS=3-2*JT
44401
44402 C...Find and sum up momentum on three sides of junction. Check flavours.
44403         DO 220 IU=1,3
44404           IJU(IU)=0
44405           DO 210 J=1,5
44406             PJU(IU,J)=0D0
44407   210     CONTINUE
44408   220   CONTINUE
44409         IU=0
44410         DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
44411           IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
44412             IU=IU+1
44413             IJU(IU)=I1
44414           ENDIF
44415           DO 230 J=1,4
44416             PJU(IU,J)=PJU(IU,J)+P(I1,J)
44417   230     CONTINUE
44418   240   CONTINUE
44419         DO 250 IU=1,3
44420           PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
44421   250   CONTINUE
44422         IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
44423      &  K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
44424           CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44425           IF(MSTU(21).GE.1) RETURN
44426         ENDIF
44427
44428 C...Calculate (approximate) boost to rest frame of junction.
44429         T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
44430      &  (PJU(1,5)*PJU(2,5))
44431         T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
44432      &  (PJU(1,5)*PJU(3,5))
44433         T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
44434      &  (PJU(2,5)*PJU(3,5))
44435         T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
44436         T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
44437         TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
44438         T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
44439         T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
44440         DO 260 J=1,3
44441           TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
44442   260   CONTINUE
44443         TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
44444         DO 270 IU=1,3
44445           PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
44446      &    TJU(3)*PJU(IU,3)
44447   270   CONTINUE
44448
44449 C...Put junction at rest if motion could give inconsistencies.
44450         IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
44451           DO 280 J=1,3
44452             TJU(J)=0D0
44453   280     CONTINUE
44454           TJU(4)=1D0
44455           PJU(1,5)=PJU(1,4)
44456           PJU(2,5)=PJU(2,4)
44457           PJU(3,5)=PJU(3,4)
44458         ENDIF
44459
44460 C...Start preparing for fragmentation of two strings from junction.
44461         ISTA=I
44462         DO 550 IU=1,2
44463           NS=IJU(IU+1)-IJU(IU)
44464
44465 C...Junction strings: find longitudinal string directions.
44466           DO 310 IS=1,NS
44467             IS1=IJU(IU)+IS-1
44468             IS2=IJU(IU)+IS
44469             DO 290 J=1,5
44470               DP(1,J)=0.5D0*P(IS1,J)
44471               IF(IS.EQ.1) DP(1,J)=P(IS1,J)
44472               DP(2,J)=0.5D0*P(IS2,J)
44473               IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
44474   290       CONTINUE
44475             IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
44476      &      PJU(IU,3)**2)
44477             IF(IS.EQ.NS) DP(2,5)=0D0
44478             DP(3,5)=DFOUR(1,1)
44479             DP(4,5)=DFOUR(2,2)
44480             DHKC=DFOUR(1,2)
44481             IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44482               DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44483               DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44484               DP(3,5)=0D0
44485               DP(4,5)=0D0
44486               DHKC=DFOUR(1,2)
44487             ENDIF
44488             DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44489             DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44490             DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44491             IN1=N+NR+4*IS-3
44492             P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44493             DO 300 J=1,4
44494               P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44495               P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44496   300       CONTINUE
44497   310     CONTINUE
44498
44499 C...Junction strings: initialize flavour, momentum and starting pos.
44500           ISAV=I
44501           MSTU91=MSTU(90)
44502   320     NTRY=NTRY+1
44503           IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44504             PARU12=4D0*PARU12
44505             PARU13=2D0*PARU13
44506             GOTO 140
44507           ELSEIF(NTRY.GT.100) THEN
44508             CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44509             IF(MSTU(21).GE.1) RETURN
44510           ENDIF
44511           I=ISAV
44512           MSTU(90)=MSTU91
44513           IRANKJ=0
44514           IE(1)=K(N+1+(JT/2)*(NP-1),3)
44515           IN(4)=N+NR+1
44516           IN(5)=IN(4)+1
44517           IN(6)=N+NR+4*NS+1
44518           DO 340 JQ=1,2
44519             DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
44520               P(IN1,1)=2-JQ
44521               P(IN1,2)=JQ-1
44522               P(IN1,3)=1D0
44523   330       CONTINUE
44524   340     CONTINUE
44525           KFL(1)=K(IJU(IU),2)
44526           PX(1)=0D0
44527           PY(1)=0D0
44528           GAM(1)=0D0
44529           DO 350 J=1,5
44530             PJU(IU+3,J)=0D0
44531   350     CONTINUE
44532
44533 C...Junction strings: find initial transverse directions.
44534           DO 360 J=1,4
44535             DP(1,J)=P(IN(4),J)
44536             DP(2,J)=P(IN(4)+1,J)
44537             DP(3,J)=0D0
44538             DP(4,J)=0D0
44539   360     CONTINUE
44540           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44541           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44542           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44543           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44544           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44545           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44546           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44547           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44548           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44549           DHC12=DFOUR(1,2)
44550           DHCX1=DFOUR(3,1)/DHC12
44551           DHCX2=DFOUR(3,2)/DHC12
44552           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44553           DHCY1=DFOUR(4,1)/DHC12
44554           DHCY2=DFOUR(4,2)/DHC12
44555           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44556           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44557           DO 370 J=1,4
44558             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44559             P(IN(6),J)=DP(3,J)
44560             P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44561      &      DHCYX*DP(3,J))
44562   370     CONTINUE
44563
44564 C...Junction strings: produce new particle, origin.
44565   380     I=I+1
44566           IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44567             CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44568             IF(MSTU(21).GE.1) RETURN
44569           ENDIF
44570           IRANKJ=IRANKJ+1
44571           K(I,1)=1
44572           K(I,3)=IE(1)
44573           K(I,4)=0
44574           K(I,5)=0
44575
44576 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
44577   390     CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
44578           IF(K(I,2).EQ.0) GOTO 320
44579           IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
44580      &    IABS(KFL(3)).GT.10) THEN
44581             IF(PYR(0).GT.PARJ(19)) GOTO 390
44582           ENDIF
44583           P(I,5)=PYMASS(K(I,2))
44584           CALL PYPTDI(KFL(1),PX(3),PY(3))
44585           PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
44586           CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
44587           IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
44588      &    MSTU(90).LT.8) THEN
44589             MSTU(90)=MSTU(90)+1
44590             MSTU(90+MSTU(90))=I
44591             PARU(90+MSTU(90))=Z
44592           ENDIF
44593           GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
44594           DO 400 J=1,3
44595             IN(J)=IN(3+J)
44596   400     CONTINUE
44597
44598 C...Junction strings: stepping within or from 'low' string region easy.
44599           IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
44600      &    P(IN(1),5)**2.GE.PR(1)) THEN
44601             P(IN(1)+2,4)=Z*P(IN(1)+2,3)
44602             P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
44603             DO 410 J=1,4
44604               P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
44605   410       CONTINUE
44606             GOTO 500
44607           ELSEIF(IN(1)+1.EQ.IN(2)) THEN
44608             P(IN(2)+2,4)=P(IN(2)+2,3)
44609             P(IN(2)+2,1)=1D0
44610             IN(2)=IN(2)+4
44611             IF(IN(2).GT.N+NR+4*NS) GOTO 320
44612             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44613               P(IN(1)+2,4)=P(IN(1)+2,3)
44614               P(IN(1)+2,1)=0D0
44615               IN(1)=IN(1)+4
44616             ENDIF
44617           ENDIF
44618
44619 C...Junction strings: find new transverse directions.
44620   420     IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
44621      &    IN(1).GT.IN(2)) GOTO 320
44622           IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
44623             DO 430 J=1,4
44624               DP(1,J)=P(IN(1),J)
44625               DP(2,J)=P(IN(2),J)
44626               DP(3,J)=0D0
44627               DP(4,J)=0D0
44628   430       CONTINUE
44629             DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44630             DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44631             DHC12=DFOUR(1,2)
44632             IF(DHC12.LE.1D-2) THEN
44633               P(IN(1)+2,4)=P(IN(1)+2,3)
44634               P(IN(1)+2,1)=0D0
44635               IN(1)=IN(1)+4
44636               GOTO 420
44637             ENDIF
44638             IN(3)=N+NR+4*NS+5
44639             DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44640             DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44641             DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44642             IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44643             IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44644             IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44645             IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44646             DHCX1=DFOUR(3,1)/DHC12
44647             DHCX2=DFOUR(3,2)/DHC12
44648             DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44649             DHCY1=DFOUR(4,1)/DHC12
44650             DHCY2=DFOUR(4,2)/DHC12
44651             DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44652             DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44653             DO 440 J=1,4
44654               DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44655               P(IN(3),J)=DP(3,J)
44656               P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44657      &        DHCYX*DP(3,J))
44658   440       CONTINUE
44659 C...Express pT with respect to new axes, if sensible.
44660             PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
44661             PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
44662             IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
44663               PX(3)=PXP
44664               PY(3)=PYP
44665             ENDIF
44666           ENDIF
44667
44668 C...Junction strings: sum up known four-momentum, coefficients for m2.
44669           DO 470 J=1,4
44670             DHG(J)=0D0
44671             P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
44672      &      PY(3)*P(IN(3)+1,J)
44673             DO 450 IN1=IN(4),IN(1)-4,4
44674               P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
44675   450       CONTINUE
44676             DO 460 IN2=IN(5),IN(2)-4,4
44677               P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
44678   460       CONTINUE
44679   470     CONTINUE
44680           DHM(1)=FOUR(I,I)
44681           DHM(2)=2D0*FOUR(I,IN(1))
44682           DHM(3)=2D0*FOUR(I,IN(2))
44683           DHM(4)=2D0*FOUR(IN(1),IN(2))
44684
44685 C...Junction strings: find coefficients for Gamma expression.
44686           DO 490 IN2=IN(1)+1,IN(2),4
44687             DO 480 IN1=IN(1),IN2-1,4
44688               DHC=2D0*FOUR(IN1,IN2)
44689               DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
44690               IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
44691               IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
44692               IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
44693   480       CONTINUE
44694   490     CONTINUE
44695
44696 C...Junction strings: solve (m2, Gamma) equation system for energies.
44697           DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
44698           IF(ABS(DHS1).LT.1D-4) GOTO 320
44699           DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
44700      &    (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
44701           DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
44702           P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
44703      &    ABS(DHS1)-DHS2/DHS1)
44704           IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
44705           P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
44706      &    (DHM(2)+DHM(4)*P(IN(2)+2,4))
44707
44708 C...Junction strings: step to new region if necessary.
44709           IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
44710             P(IN(2)+2,4)=P(IN(2)+2,3)
44711             P(IN(2)+2,1)=1D0
44712             IN(2)=IN(2)+4
44713             IF(IN(2).GT.N+NR+4*NS) GOTO 320
44714             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44715               P(IN(1)+2,4)=P(IN(1)+2,3)
44716               P(IN(1)+2,1)=0D0
44717               IN(1)=IN(1)+4
44718             ENDIF
44719             GOTO 420
44720           ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
44721             P(IN(1)+2,4)=P(IN(1)+2,3)
44722             P(IN(1)+2,1)=0D0
44723             IN(1)=IN(1)+JS
44724             GOTO 890
44725           ENDIF
44726
44727 C...Junction strings: particle four-momentum, remainder, loop back.
44728   500     DO 510 J=1,4
44729             P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
44730      &      P(IN(2)+2,4)*P(IN(2),J)
44731             PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
44732   510     CONTINUE
44733           IF(P(I,4).LT.P(I,5)) GOTO 320
44734           PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
44735      &    TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
44736           IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
44737             KFL(1)=-KFL(3)
44738             PX(1)=-PX(3)
44739             PY(1)=-PY(3)
44740             GAM(1)=GAM(3)
44741             IF(IN(3).NE.IN(6)) THEN
44742               DO 520 J=1,4
44743                 P(IN(6),J)=P(IN(3),J)
44744                 P(IN(6)+1,J)=P(IN(3)+1,J)
44745   520         CONTINUE
44746             ENDIF
44747             DO 530 JQ=1,2
44748               IN(3+JQ)=IN(JQ)
44749               P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
44750               P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
44751   530       CONTINUE
44752             GOTO 380
44753           ENDIF
44754
44755 C...Junction strings: save quantities left after each string.
44756           IF(IABS(KFL(1)).GT.10) GOTO 320
44757           I=I-1
44758           KFJH(IU)=KFL(1)
44759           DO 540 J=1,4
44760             PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
44761   540     CONTINUE
44762   550   CONTINUE
44763
44764 C...Junction strings: put together to new effective string endpoint.
44765         NJS(JT)=I-ISTA
44766         KFJS(JT)=K(K(MJU(JT+2),3),2)
44767         KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
44768         IF(KFJH(1).EQ.KFJH(2)) KFLS=3
44769         IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
44770      &  IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
44771      &  KFLS,KFJH(1))
44772         DO 560 J=1,4
44773           PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
44774           PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
44775   560   CONTINUE
44776         PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
44777      &  PJS(JT,3)**2))
44778   570 CONTINUE
44779
44780 C...Open versus closed strings. Choose breakup region for latter.
44781   580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
44782         NS=MJU(2)-MJU(1)
44783         NB=MJU(1)-N
44784       ELSEIF(MJU(1).NE.0) THEN
44785         NS=N+NR-MJU(1)
44786         NB=MJU(1)-N
44787       ELSEIF(MJU(2).NE.0) THEN
44788         NS=MJU(2)-N
44789         NB=1
44790       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
44791         NS=NR-1
44792         NB=1
44793       ELSE
44794         NS=NR+1
44795         W2SUM=0D0
44796         DO 590 IS=1,NR
44797           P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
44798           W2SUM=W2SUM+P(N+NR+IS,1)
44799   590   CONTINUE
44800         W2RAN=PYR(0)*W2SUM
44801         NB=0
44802   600   NB=NB+1
44803         W2SUM=W2SUM-P(N+NR+NB,1)
44804         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
44805       ENDIF
44806
44807 C...Find longitudinal string directions (i.e. lightlike four-vectors).
44808       DO 630 IS=1,NS
44809         IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
44810         IS2=N+IS+NB-NR*((IS+NB-1)/NR)
44811         DO 610 J=1,5
44812           DP(1,J)=P(IS1,J)
44813           IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
44814           IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
44815           DP(2,J)=P(IS2,J)
44816           IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
44817           IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
44818   610   CONTINUE
44819         DP(3,5)=DFOUR(1,1)
44820         DP(4,5)=DFOUR(2,2)
44821         DHKC=DFOUR(1,2)
44822         IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44823           DP(3,5)=DP(1,5)**2
44824           DP(4,5)=DP(2,5)**2
44825           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
44826           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
44827           DHKC=DFOUR(1,2)
44828         ENDIF
44829         DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44830         DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44831         DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44832         IN1=N+NR+4*IS-3
44833         P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44834         DO 620 J=1,4
44835           P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44836           P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44837   620   CONTINUE
44838   630 CONTINUE
44839
44840 C...Begin initialization: sum up energy, set starting position.
44841       ISAV=I
44842       MSTU91=MSTU(90)
44843   640 NTRY=NTRY+1
44844       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44845         PARU12=4D0*PARU12
44846         PARU13=2D0*PARU13
44847         GOTO 140
44848       ELSEIF(NTRY.GT.100) THEN
44849         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44850         IF(MSTU(21).GE.1) RETURN
44851       ENDIF
44852       I=ISAV
44853       MSTU(90)=MSTU91
44854       DO 660 J=1,4
44855         P(N+NRS,J)=0D0
44856         DO 650 IS=1,NR
44857           P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
44858   650   CONTINUE
44859   660 CONTINUE
44860       DO 680 JT=1,2
44861         IRANK(JT)=0
44862         IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
44863         IF(NS.GT.NR) IRANK(JT)=1
44864         IE(JT)=K(N+1+(JT/2)*(NP-1),3)
44865         IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
44866         IN(3*JT+2)=IN(3*JT+1)+1
44867         IN(3*JT+3)=N+NR+4*NS+2*JT-1
44868         DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
44869           P(IN1,1)=2-JT
44870           P(IN1,2)=JT-1
44871           P(IN1,3)=1D0
44872   670   CONTINUE
44873   680 CONTINUE
44874 C.. MOPS variables and switches
44875       NRVMO=0
44876       XBMO=1D0
44877       MSTU(121)=0
44878       MSTU(122)=0
44879
44880 C...Initialize flavour and pT variables for open string.
44881       IF(NS.LT.NR) THEN
44882         PX(1)=0D0
44883         PY(1)=0D0
44884         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
44885         PX(2)=-PX(1)
44886         PY(2)=-PY(1)
44887         DO 690 JT=1,2
44888           KFL(JT)=K(IE(JT),2)
44889           IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
44890           MSTJ(93)=1
44891           PMQ(JT)=PYMASS(KFL(JT))
44892           GAM(JT)=0D0
44893   690   CONTINUE
44894
44895 C...Closed string: random initial breakup flavour, pT and vertex.
44896       ELSE
44897         KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
44898         IBMO=0
44899   700   CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
44900 C.. Closed string: first vertex diq attempt => enforced second
44901 C.. vertex diq
44902         IF(IABS(KFL(1)).GT.10)THEN
44903            IBMO=1
44904            MSTU(121)=0
44905            GOTO 700
44906         ENDIF
44907         IF(IBMO.EQ.1) MSTU(121)=-1
44908         KFL(2)=-KFL(1)
44909         CALL PYPTDI(KFL(1),PX(1),PY(1))
44910         PX(2)=-PX(1)
44911         PY(2)=-PY(1)
44912         PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
44913   710   CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
44914         ZR=PR3/(Z*P(N+NR+1,5)**2)
44915         IF(ZR.GE.1D0) GOTO 710
44916         DO 720 JT=1,2
44917           MSTJ(93)=1
44918           PMQ(JT)=PYMASS(KFL(JT))
44919           GAM(JT)=PR3*(1D0-Z)/Z
44920           IN1=N+NR+3+4*(JT/2)*(NS-1)
44921           P(IN1,JT)=1D0-Z
44922           P(IN1,3-JT)=JT-1
44923           P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
44924           P(IN1+1,JT)=ZR
44925           P(IN1+1,3-JT)=2-JT
44926           P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
44927   720   CONTINUE
44928       ENDIF
44929 C.. MOPS variables
44930       DO 730 JT=1,2
44931          XTMO(JT)=1D0
44932          PM2QMO(JT)=PMQ(JT)**2
44933          IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
44934   730 CONTINUE
44935
44936 C...Find initial transverse directions (i.e. spacelike four-vectors).
44937       DO 770 JT=1,2
44938         IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
44939           IN1=IN(3*JT+1)
44940           IN3=IN(3*JT+3)
44941           DO 740 J=1,4
44942             DP(1,J)=P(IN1,J)
44943             DP(2,J)=P(IN1+1,J)
44944             DP(3,J)=0D0
44945             DP(4,J)=0D0
44946   740     CONTINUE
44947           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44948           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44949           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44950           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44951           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44952           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44953           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44954           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44955           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44956           DHC12=DFOUR(1,2)
44957           DHCX1=DFOUR(3,1)/DHC12
44958           DHCX2=DFOUR(3,2)/DHC12
44959           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44960           DHCY1=DFOUR(4,1)/DHC12
44961           DHCY2=DFOUR(4,2)/DHC12
44962           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44963           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44964           DO 750 J=1,4
44965             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44966             P(IN3,J)=DP(3,J)
44967             P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44968      &      DHCYX*DP(3,J))
44969   750     CONTINUE
44970         ELSE
44971           DO 760 J=1,4
44972             P(IN3+2,J)=P(IN3,J)
44973             P(IN3+3,J)=P(IN3+1,J)
44974   760     CONTINUE
44975         ENDIF
44976   770 CONTINUE
44977
44978 C...Remove energy used up in junction string fragmentation.
44979       IF(MJU(1)+MJU(2).GT.0) THEN
44980         DO 790 JT=1,2
44981           IF(NJS(JT).EQ.0) GOTO 790
44982           DO 780 J=1,4
44983             P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
44984   780     CONTINUE
44985   790   CONTINUE
44986       ENDIF
44987
44988 C...Produce new particle: side, origin.
44989   800 I=I+1
44990       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44991         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44992         IF(MSTU(21).GE.1) RETURN
44993       ENDIF
44994 C.. New side priority for popcorn systems
44995       IF(MSTU(121).LE.0)THEN
44996          JT=1.5D0+PYR(0)
44997          IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
44998          IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
44999       ENDIF
45000       JR=3-JT
45001       JS=3-2*JT
45002       IRANK(JT)=IRANK(JT)+1
45003       K(I,1)=1
45004       K(I,3)=IE(JT)
45005       K(I,4)=0
45006       K(I,5)=0
45007
45008 C...Generate flavour, hadron and pT.
45009   810 CONTINUE
45010       CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
45011       IF(K(I,2).EQ.0) GOTO 640
45012       MU90MO=MSTU(90)
45013       IF(MSTU(121).EQ.-1) GOTO 840
45014       IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
45015      &IABS(KFL(3)).GT.10) THEN
45016         IF(PYR(0).GT.PARJ(19)) GOTO 810
45017       ENDIF
45018       P(I,5)=PYMASS(K(I,2))
45019       CALL PYPTDI(KFL(JT),PX(3),PY(3))
45020       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
45021
45022 C...Final hadrons for small invariant mass.
45023       MSTJ(93)=1
45024       PMQ(3)=PYMASS(KFL(3))
45025       PARJST=PARJ(33)
45026       IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
45027       WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
45028       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
45029      &WMIN-0.5D0*PARJ(36)*PMQ(3)
45030       WREM2=FOUR(N+NRS,N+NRS)
45031       IF(WREM2.LT.0.10D0) GOTO 640
45032       IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
45033      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
45034
45035 C...Choose z, which gives Gamma. Shift z for heavy flavours.
45036       CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
45037       IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
45038      &MSTU(90).LT.8) THEN
45039         MSTU(90)=MSTU(90)+1
45040         MSTU(90+MSTU(90))=I
45041         PARU(90+MSTU(90))=Z
45042       ENDIF
45043       KFL1A=IABS(KFL(1))
45044       KFL2A=IABS(KFL(2))
45045       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45046      &MOD(KFL2A/1000,10)).GE.4) THEN
45047         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45048         PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
45049         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
45050         PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45051         IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
45052       ENDIF
45053       GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
45054
45055 C.. MOPS baryon model modification
45056       XTMO3=(1D0-Z)*XTMO(JT)
45057       IF(IABS(KFL(3)).LE.10) NRVMO=0
45058       IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
45059          GTSTMO=1D0
45060          PTSTMO=1D0
45061          RTSTMO=PYR(0)
45062          IF(IABS(KFL(JT)).LE.10)THEN
45063             XBMO=MIN(XTMO3,1D0-(2D-10))
45064             GBMO=GAM(3)
45065             PMMO=0D0
45066             PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
45067             GTSTMO=1D0-PARF(192)**PGMO
45068          ELSE
45069             IF(IRANK(JT).EQ.1) THEN
45070                GBMO=GAM(JT)
45071                PMMO=0D0
45072                XBMO=1D0
45073             ENDIF
45074             IF(XBMO.LT.1D0-(1D-10))THEN
45075                PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
45076                GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
45077                PGMO=PGNMO
45078             ENDIF
45079             IF(MSTJ(12).GE.5)THEN
45080                PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
45081                PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
45082                PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
45083                PMMO=PMNMO
45084             ENDIF
45085          ENDIF
45086
45087 C.. MOPS Accepting popcorn system hadron.
45088          IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
45089             IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
45090                NRVMO=I-N-NR
45091                IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
45092                   CALL PYERRM(11,
45093      &                 '(PYSTRF:) no more memory left in PYJETS')
45094                   IF(MSTU(21).GE.1) RETURN
45095                ENDIF
45096                IMO=I
45097                KFLMO=KFL(JT)
45098                PMQMO=PMQ(JT)
45099                PXMO=PX(JT)
45100                PYMO=PY(JT)
45101                GAMMO=GAM(JT)
45102                IRMO=IRANK(JT)
45103                XMO=XTMO(JT)
45104                DO 830 J=1,9
45105                   IF(J.LE.5) THEN
45106                      DO 820 LINE=1,I-N-NR
45107                         P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
45108                         K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
45109   820                CONTINUE
45110                   ENDIF
45111                   INMO(J)=IN(J)
45112   830          CONTINUE
45113             ENDIF
45114          ELSE
45115 C..Reject popcorn system, flag=-1 if enforcing new one
45116             MSTU(121)=-1
45117             IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
45118          ENDIF
45119       ENDIF
45120
45121
45122 C..Lift restoring string outside MOPS block
45123   840 IF(MSTU(121).LT.0) THEN
45124          IF(MSTU(121).EQ.-2) MSTU(121)=0
45125          MSTU(90)=MU90MO
45126          NRVMO=0
45127          IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
45128          I=IMO
45129          KFL(JT)=KFLMO
45130          PMQ(JT)=PMQMO
45131          PX(JT)=PXMO
45132          PY(JT)=PYMO
45133          GAM(JT)=GAMMO
45134          IRANK(JT)=IRMO
45135          XTMO(JT)=XMO
45136          DO 860 J=1,9
45137             IF(J.LE.5) THEN
45138                DO 850 LINE=1,I-N-NR
45139                   P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
45140                   K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
45141   850          CONTINUE
45142             ENDIF
45143             IN(J)=INMO(J)
45144   860    CONTINUE
45145          GOTO 810
45146       ENDIF
45147       XTMO(JT)=XTMO3
45148 C.. MOPS end of modification
45149
45150       DO 870 J=1,3
45151         IN(J)=IN(3*JT+J)
45152   870 CONTINUE
45153
45154 C...Stepping within or from 'low' string region easy.
45155       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
45156      &P(IN(1),5)**2.GE.PR(JT)) THEN
45157         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
45158         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
45159         DO 880 J=1,4
45160           P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
45161   880   CONTINUE
45162         GOTO 970
45163       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
45164         P(IN(JR)+2,4)=P(IN(JR)+2,3)
45165         P(IN(JR)+2,JT)=1D0
45166         IN(JR)=IN(JR)+4*JS
45167         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45168         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45169           P(IN(JT)+2,4)=P(IN(JT)+2,3)
45170           P(IN(JT)+2,JT)=0D0
45171           IN(JT)=IN(JT)+4*JS
45172         ENDIF
45173       ENDIF
45174
45175 C...Find new transverse directions (i.e. spacelike string vectors).
45176   890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
45177      &IN(1).GT.IN(2)) GOTO 640
45178       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
45179         DO 900 J=1,4
45180           DP(1,J)=P(IN(1),J)
45181           DP(2,J)=P(IN(2),J)
45182           DP(3,J)=0D0
45183           DP(4,J)=0D0
45184   900   CONTINUE
45185         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
45186         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
45187         DHC12=DFOUR(1,2)
45188         IF(DHC12.LE.1D-2) THEN
45189           P(IN(JT)+2,4)=P(IN(JT)+2,3)
45190           P(IN(JT)+2,JT)=0D0
45191           IN(JT)=IN(JT)+4*JS
45192           GOTO 890
45193         ENDIF
45194         IN(3)=N+NR+4*NS+5
45195         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
45196         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
45197         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
45198         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
45199         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
45200         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
45201         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
45202         DHCX1=DFOUR(3,1)/DHC12
45203         DHCX2=DFOUR(3,2)/DHC12
45204         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
45205         DHCY1=DFOUR(4,1)/DHC12
45206         DHCY2=DFOUR(4,2)/DHC12
45207         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
45208         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
45209         DO 910 J=1,4
45210           DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
45211           P(IN(3),J)=DP(3,J)
45212           P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
45213      &    DHCYX*DP(3,J))
45214   910   CONTINUE
45215 C...Express pT with respect to new axes, if sensible.
45216         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
45217      &  FOUR(IN(3*JT+3)+1,IN(3)))
45218         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
45219      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
45220         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
45221           PX(3)=PXP
45222           PY(3)=PYP
45223         ENDIF
45224       ENDIF
45225
45226 C...Sum up known four-momentum. Gives coefficients for m2 expression.
45227       DO 940 J=1,4
45228         DHG(J)=0D0
45229         P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
45230      &  PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
45231         DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
45232           P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
45233   920   CONTINUE
45234         DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
45235           P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
45236   930   CONTINUE
45237   940 CONTINUE
45238       DHM(1)=FOUR(I,I)
45239       DHM(2)=2D0*FOUR(I,IN(1))
45240       DHM(3)=2D0*FOUR(I,IN(2))
45241       DHM(4)=2D0*FOUR(IN(1),IN(2))
45242
45243 C...Find coefficients for Gamma expression.
45244       DO 960 IN2=IN(1)+1,IN(2),4
45245         DO 950 IN1=IN(1),IN2-1,4
45246           DHC=2D0*FOUR(IN1,IN2)
45247           DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
45248           IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
45249           IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
45250           IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
45251   950   CONTINUE
45252   960 CONTINUE
45253
45254 C...Solve (m2, Gamma) equation system for energies taken.
45255       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
45256       IF(ABS(DHS1).LT.1D-4) GOTO 640
45257       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
45258      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
45259       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
45260       P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
45261      &ABS(DHS1)-DHS2/DHS1)
45262       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
45263       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
45264      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
45265
45266 C...Step to new region if necessary.
45267       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
45268         P(IN(JR)+2,4)=P(IN(JR)+2,3)
45269         P(IN(JR)+2,JT)=1D0
45270         IN(JR)=IN(JR)+4*JS
45271         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45272         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45273           P(IN(JT)+2,4)=P(IN(JT)+2,3)
45274           P(IN(JT)+2,JT)=0D0
45275           IN(JT)=IN(JT)+4*JS
45276         ENDIF
45277         GOTO 890
45278       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
45279         P(IN(JT)+2,4)=P(IN(JT)+2,3)
45280         P(IN(JT)+2,JT)=0D0
45281         IN(JT)=IN(JT)+4*JS
45282         GOTO 890
45283       ENDIF
45284
45285 C...Four-momentum of particle. Remaining quantities. Loop back.
45286   970 DO 980 J=1,4
45287         P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
45288         P(N+NRS,J)=P(N+NRS,J)-P(I,J)
45289   980 CONTINUE
45290       IF(P(I,4).LT.P(I,5)) GOTO 640
45291       KFL(JT)=-KFL(3)
45292       PMQ(JT)=PMQ(3)
45293       PX(JT)=-PX(3)
45294       PY(JT)=-PY(3)
45295       GAM(JT)=GAM(3)
45296       IF(IN(3).NE.IN(3*JT+3)) THEN
45297         DO 990 J=1,4
45298           P(IN(3*JT+3),J)=P(IN(3),J)
45299           P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
45300   990   CONTINUE
45301       ENDIF
45302       DO 1000 JQ=1,2
45303         IN(3*JT+JQ)=IN(JQ)
45304         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
45305         P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
45306  1000 CONTINUE
45307       GOTO 800
45308
45309 C...Final hadron: side, flavour, hadron, mass.
45310  1010 I=I+1
45311       K(I,1)=1
45312       K(I,3)=IE(JR)
45313       K(I,4)=0
45314       K(I,5)=0
45315       CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
45316       IF(K(I,2).EQ.0) GOTO 640
45317       P(I,5)=PYMASS(K(I,2))
45318       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45319
45320 C...Final two hadrons: find common setup of four-vectors.
45321       JQ=1
45322       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
45323      &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
45324       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
45325       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
45326       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
45327       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
45328         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
45329         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
45330         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
45331      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
45332       ENDIF
45333
45334 C...Solve kinematics for final two hadrons, if possible.
45335       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
45336       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
45337       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
45338       IF(FD.GE.1D0) GOTO 640
45339       FA=WREM2+PR(JT)-PR(JR)
45340       FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
45341       PREVCF=PARJ(42)
45342       IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
45343       PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
45344       FB=SIGN(FB,JS*(PYR(0)-PREV))
45345       KFL1A=IABS(KFL(1))
45346       KFL2A=IABS(KFL(2))
45347       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45348      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
45349      &4D0*WREM2*PR(JT))),DBLE(JS))
45350       DO 1020 J=1,4
45351         P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
45352      &  P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
45353      &  DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
45354         P(I,J)=P(N+NRS,J)-P(I-1,J)
45355  1020 CONTINUE
45356       IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
45357
45358 C...Mark jets as fragmented and give daughter pointers.
45359       N=I-NRS+1
45360       DO 1030 I=NSAV+1,NSAV+NP
45361         IM=K(I,3)
45362         K(IM,1)=K(IM,1)+10
45363         IF(MSTU(16).NE.2) THEN
45364           K(IM,4)=NSAV+1
45365           K(IM,5)=NSAV+1
45366         ELSE
45367           K(IM,4)=NSAV+2
45368           K(IM,5)=N
45369         ENDIF
45370  1030 CONTINUE
45371
45372 C...Document string system. Move up particles.
45373       NSAV=NSAV+1
45374       K(NSAV,1)=11
45375       K(NSAV,2)=92
45376       K(NSAV,3)=IP
45377       K(NSAV,4)=NSAV+1
45378       K(NSAV,5)=N
45379       DO 1040 J=1,4
45380         P(NSAV,J)=DPS(J)
45381         V(NSAV,J)=V(IP,J)
45382  1040 CONTINUE
45383       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45384       V(NSAV,5)=0D0
45385       DO 1060 I=NSAV+1,N
45386         DO 1050 J=1,5
45387           K(I,J)=K(I+NRS-1,J)
45388           P(I,J)=P(I+NRS-1,J)
45389           V(I,J)=0D0
45390  1050   CONTINUE
45391  1060 CONTINUE
45392       MSTU91=MSTU(90)
45393       DO 1070 IZ=MSTU90+1,MSTU91
45394         MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
45395         PARU9T(IZ)=PARU(90+IZ)
45396  1070 CONTINUE
45397       MSTU(90)=MSTU90
45398
45399 C...Order particles in rank along the chain. Update mother pointer.
45400       DO 1090 I=NSAV+1,N
45401         DO 1080 J=1,5
45402           K(I-NSAV+N,J)=K(I,J)
45403           P(I-NSAV+N,J)=P(I,J)
45404  1080   CONTINUE
45405  1090 CONTINUE
45406       I1=NSAV
45407       DO 1120 I=N+1,2*N-NSAV
45408         IF(K(I,3).NE.IE(1)) GOTO 1120
45409         I1=I1+1
45410         DO 1100 J=1,5
45411           K(I1,J)=K(I,J)
45412           P(I1,J)=P(I,J)
45413  1100   CONTINUE
45414         IF(MSTU(16).NE.2) K(I1,3)=NSAV
45415         DO 1110 IZ=MSTU90+1,MSTU91
45416           IF(MSTU9T(IZ).EQ.I) THEN
45417             MSTU(90)=MSTU(90)+1
45418             MSTU(90+MSTU(90))=I1
45419             PARU(90+MSTU(90))=PARU9T(IZ)
45420           ENDIF
45421  1110   CONTINUE
45422  1120 CONTINUE
45423       DO 1150 I=2*N-NSAV,N+1,-1
45424         IF(K(I,3).EQ.IE(1)) GOTO 1150
45425         I1=I1+1
45426         DO 1130 J=1,5
45427           K(I1,J)=K(I,J)
45428           P(I1,J)=P(I,J)
45429  1130   CONTINUE
45430         IF(MSTU(16).NE.2) K(I1,3)=NSAV
45431         DO 1140 IZ=MSTU90+1,MSTU91
45432           IF(MSTU9T(IZ).EQ.I) THEN
45433             MSTU(90)=MSTU(90)+1
45434             MSTU(90+MSTU(90))=I1
45435             PARU(90+MSTU(90))=PARU9T(IZ)
45436           ENDIF
45437  1140   CONTINUE
45438  1150 CONTINUE
45439
45440 C...Boost back particle system. Set production vertices.
45441       IF(MBST.EQ.0) THEN
45442         MSTU(33)=1
45443         CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
45444      &  DPS(3)/DPS(4))
45445       ELSE
45446         DO 1160 I=NSAV+1,N
45447           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
45448           IF(P(I,3).GT.0D0) THEN
45449             HHPEZ=(P(I,4)+P(I,3))*HHBZ
45450             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
45451             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45452           ELSE
45453             HHPEZ=(P(I,4)-P(I,3))/HHBZ
45454             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
45455             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45456           ENDIF
45457  1160   CONTINUE
45458       ENDIF
45459       DO 1180 I=NSAV+1,N
45460         DO 1170 J=1,4
45461           V(I,J)=V(IP,J)
45462  1170   CONTINUE
45463  1180 CONTINUE
45464
45465       RETURN
45466       END
45467
45468 C*********************************************************************
45469
45470 C...PYINDF
45471 C...Handles the fragmentation of a jet system (or a single
45472 C...jet) according to independent fragmentation models.
45473
45474       SUBROUTINE PYINDF(IP)
45475
45476 C...Double precision and integer declarations.
45477       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45478       IMPLICIT INTEGER(I-N)
45479       INTEGER PYK,PYCHGE,PYCOMP
45480 C...Commonblocks.
45481       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45482       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45483       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45484       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
45485 C...Local arrays.
45486       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
45487      &KFLO(2),PXO(2),PYO(2),WO(2)
45488
45489 C.. MOPS error message
45490       IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
45491      &' are not treated as expected in independent fragmentation')
45492
45493 C...Reset counters. Identify parton system and take copy. Check flavour.
45494       NSAV=N
45495       MSTU90=MSTU(90)
45496       NJET=0
45497       KQSUM=0
45498       DO 100 J=1,5
45499         DPS(J)=0D0
45500   100 CONTINUE
45501       I=IP-1
45502   110 I=I+1
45503       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
45504         CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
45505         IF(MSTU(21).GE.1) RETURN
45506       ENDIF
45507       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
45508       KC=PYCOMP(K(I,2))
45509       IF(KC.EQ.0) GOTO 110
45510       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
45511       IF(KQ.EQ.0) GOTO 110
45512       NJET=NJET+1
45513       IF(KQ.NE.2) KQSUM=KQSUM+KQ
45514       DO 120 J=1,5
45515         K(NSAV+NJET,J)=K(I,J)
45516         P(NSAV+NJET,J)=P(I,J)
45517         DPS(J)=DPS(J)+P(I,J)
45518   120 CONTINUE
45519       K(NSAV+NJET,3)=I
45520       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
45521      &K(I+1,1).EQ.2)) GOTO 110
45522       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
45523         CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
45524         IF(MSTU(21).GE.1) RETURN
45525       ENDIF
45526
45527 C...Boost copied system to CM frame. Find CM energy and sum flavours.
45528       IF(NJET.NE.1) THEN
45529         MSTU(33)=1
45530         CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
45531      &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
45532       ENDIF
45533       PECM=0D0
45534       DO 130 J=1,3
45535         NFI(J)=0
45536   130 CONTINUE
45537       DO 140 I=NSAV+1,NSAV+NJET
45538         PECM=PECM+P(I,4)
45539         KFA=IABS(K(I,2))
45540         IF(KFA.LE.3) THEN
45541           NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
45542         ELSEIF(KFA.GT.1000) THEN
45543           KFLA=MOD(KFA/1000,10)
45544           KFLB=MOD(KFA/100,10)
45545           IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
45546           IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
45547         ENDIF
45548   140 CONTINUE
45549
45550 C...Loop over attempts made. Reset counters.
45551       NTRY=0
45552   150 NTRY=NTRY+1
45553       IF(NTRY.GT.200) THEN
45554         CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
45555         IF(MSTU(21).GE.1) RETURN
45556       ENDIF
45557       N=NSAV+NJET
45558       MSTU(90)=MSTU90
45559       DO 160 J=1,3
45560         NFL(J)=NFI(J)
45561         IFET(J)=0
45562         KFLF(J)=0
45563   160 CONTINUE
45564
45565 C...Loop over jets to be fragmented.
45566       DO 230 IP1=NSAV+1,NSAV+NJET
45567         MSTJ(91)=0
45568         NSAV1=N
45569         MSTU91=MSTU(90)
45570
45571 C...Initial flavour and momentum values. Jet along +z axis.
45572         KFLH=IABS(K(IP1,2))
45573         IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
45574         KFLO(2)=0
45575         WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
45576
45577 C...Initial values for quark or diquark jet.
45578   170   IF(IABS(K(IP1,2)).NE.21) THEN
45579           NSTR=1
45580           KFLO(1)=K(IP1,2)
45581           CALL PYPTDI(0,PXO(1),PYO(1))
45582           WO(1)=WF
45583
45584 C...Initial values for gluon treated like random quark jet.
45585         ELSEIF(MSTJ(2).LE.2) THEN
45586           NSTR=1
45587           IF(MSTJ(2).EQ.2) MSTJ(91)=1
45588           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45589           CALL PYPTDI(0,PXO(1),PYO(1))
45590           WO(1)=WF
45591
45592 C...Initial values for gluon treated like quark-antiquark jet pair,
45593 C...sharing energy according to Altarelli-Parisi splitting function.
45594         ELSE
45595           NSTR=2
45596           IF(MSTJ(2).EQ.4) MSTJ(91)=1
45597           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45598           KFLO(2)=-KFLO(1)
45599           CALL PYPTDI(0,PXO(1),PYO(1))
45600           PXO(2)=-PXO(1)
45601           PYO(2)=-PYO(1)
45602           WO(1)=WF*PYR(0)**(1D0/3D0)
45603           WO(2)=WF-WO(1)
45604         ENDIF
45605
45606 C...Initial values for rank, flavour, pT and W+.
45607         DO 220 ISTR=1,NSTR
45608   180     I=N
45609           MSTU(90)=MSTU91
45610           IRANK=0
45611           KFL1=KFLO(ISTR)
45612           PX1=PXO(ISTR)
45613           PY1=PYO(ISTR)
45614           W=WO(ISTR)
45615
45616 C...New hadron. Generate flavour and hadron species.
45617   190     I=I+1
45618           IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
45619             CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
45620             IF(MSTU(21).GE.1) RETURN
45621           ENDIF
45622           IRANK=IRANK+1
45623           K(I,1)=1
45624           K(I,3)=IP1
45625           K(I,4)=0
45626           K(I,5)=0
45627   200     CALL PYKFDI(KFL1,0,KFL2,K(I,2))
45628           IF(K(I,2).EQ.0) GOTO 180
45629           IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
45630             IF(PYR(0).GT.PARJ(19)) GOTO 200
45631           ENDIF
45632
45633 C...Find hadron mass. Generate four-momentum.
45634           P(I,5)=PYMASS(K(I,2))
45635           CALL PYPTDI(KFL1,PX2,PY2)
45636           P(I,1)=PX1+PX2
45637           P(I,2)=PY1+PY2
45638           PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
45639           CALL PYZDIS(KFL1,KFL2,PR,Z)
45640           MZSAV=0
45641           IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
45642             MZSAV=1
45643             MSTU(90)=MSTU(90)+1
45644             MSTU(90+MSTU(90))=I
45645             PARU(90+MSTU(90))=Z
45646           ENDIF
45647           P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
45648           P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
45649           IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
45650      &    P(I,3).LE.0.001D0) THEN
45651             IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
45652             P(I,3)=0.0001D0
45653             P(I,4)=SQRT(PR)
45654             Z=P(I,4)/W
45655           ENDIF
45656
45657 C...Remaining flavour and momentum.
45658           KFL1=-KFL2
45659           PX1=-PX2
45660           PY1=-PY2
45661           W=(1D0-Z)*W
45662           DO 210 J=1,5
45663             V(I,J)=0D0
45664   210     CONTINUE
45665
45666 C...Check if pL acceptable. Go back for new hadron if enough energy.
45667           IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
45668             I=I-1
45669             IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
45670           ENDIF
45671           IF(W.GT.PARJ(31)) GOTO 190
45672           N=I
45673   220   CONTINUE
45674         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
45675         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
45676
45677 C...Rotate jet to new direction.
45678         THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
45679         PHI=PYANGL(P(IP1,1),P(IP1,2))
45680         MSTU(33)=1
45681         CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
45682         K(K(IP1,3),4)=NSAV1+1
45683         K(K(IP1,3),5)=N
45684
45685 C...End of jet generation loop. Skip conservation in some cases.
45686   230 CONTINUE
45687       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
45688       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
45689
45690 C...Subtract off produced hadron flavours, finished if zero.
45691       DO 240 I=NSAV+NJET+1,N
45692         KFA=IABS(K(I,2))
45693         KFLA=MOD(KFA/1000,10)
45694         KFLB=MOD(KFA/100,10)
45695         KFLC=MOD(KFA/10,10)
45696         IF(KFLA.EQ.0) THEN
45697           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
45698           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
45699         ELSE
45700           IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
45701           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
45702           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
45703         ENDIF
45704   240 CONTINUE
45705       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45706      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45707       IF(NREQ.EQ.0) GOTO 320
45708
45709 C...Take away flavour of low-momentum particles until enough freedom.
45710       NREM=0
45711   250 IREM=0
45712       P2MIN=PECM**2
45713       DO 260 I=NSAV+NJET+1,N
45714         P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
45715         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
45716         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
45717   260 CONTINUE
45718       IF(IREM.EQ.0) GOTO 150
45719       K(IREM,1)=7
45720       KFA=IABS(K(IREM,2))
45721       KFLA=MOD(KFA/1000,10)
45722       KFLB=MOD(KFA/100,10)
45723       KFLC=MOD(KFA/10,10)
45724       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
45725       IF(K(IREM,1).EQ.8) GOTO 250
45726       IF(KFLA.EQ.0) THEN
45727         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
45728         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
45729         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
45730       ELSE
45731         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
45732         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
45733         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
45734       ENDIF
45735       NREM=NREM+1
45736       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45737      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45738       IF(NREQ.GT.NREM) GOTO 250
45739       DO 270 I=NSAV+NJET+1,N
45740         IF(K(I,1).EQ.8) K(I,1)=1
45741   270 CONTINUE
45742
45743 C...Find combination of existing and new flavours for hadron.
45744   280 NFET=2
45745       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
45746       IF(NREQ.LT.NREM) NFET=1
45747       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
45748       DO 290 J=1,NFET
45749         IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
45750         KFLF(J)=ISIGN(1,NFL(1))
45751         IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
45752         IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
45753   290 CONTINUE
45754       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
45755      &GOTO 280
45756       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
45757      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
45758      &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
45759       IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
45760       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
45761       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
45762       IF(NFET.LE.2) KFLF(3)=0
45763       IF(KFLF(3).NE.0) THEN
45764         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
45765      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
45766         IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
45767      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
45768       ELSE
45769         KFLFC=KFLF(1)
45770       ENDIF
45771       CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
45772       IF(KF.EQ.0) GOTO 280
45773       DO 300 J=1,MAX(2,NFET)
45774         NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
45775   300 CONTINUE
45776
45777 C...Store hadron at random among free positions.
45778       NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
45779       DO 310 I=NSAV+NJET+1,N
45780         IF(K(I,1).EQ.7) NPOS=NPOS-1
45781         IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
45782         K(I,1)=1
45783         K(I,2)=KF
45784         P(I,5)=PYMASS(K(I,2))
45785         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45786   310 CONTINUE
45787       NREM=NREM-1
45788       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45789      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45790       IF(NREM.GT.0) GOTO 280
45791
45792 C...Compensate for missing momentum in global scheme (3 options).
45793   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
45794         DO 340 J=1,3
45795           PSI(J)=0D0
45796           DO 330 I=NSAV+NJET+1,N
45797             PSI(J)=PSI(J)+P(I,J)
45798   330     CONTINUE
45799   340   CONTINUE
45800         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
45801         PWS=0D0
45802         DO 350 I=NSAV+NJET+1,N
45803           IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
45804           IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45805      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45806           IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
45807   350   CONTINUE
45808         DO 370 I=NSAV+NJET+1,N
45809           IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
45810           IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45811      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45812           IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
45813           DO 360 J=1,3
45814             P(I,J)=P(I,J)-PSI(J)*PW/PWS
45815   360     CONTINUE
45816           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45817   370   CONTINUE
45818
45819 C...Compensate for missing momentum withing each jet separately.
45820       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
45821         DO 390 I=N+1,N+NJET
45822           K(I,1)=0
45823           DO 380 J=1,5
45824             P(I,J)=0D0
45825   380     CONTINUE
45826   390   CONTINUE
45827         DO 410 I=NSAV+NJET+1,N
45828           IR1=K(I,3)
45829           IR2=N+IR1-NSAV
45830           K(IR2,1)=K(IR2,1)+1
45831           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45832      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45833           DO 400 J=1,3
45834             P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
45835   400     CONTINUE
45836           P(IR2,4)=P(IR2,4)+P(I,4)
45837           P(IR2,5)=P(IR2,5)+PLS
45838   410   CONTINUE
45839         PSS=0D0
45840         DO 420 I=N+1,N+NJET
45841           IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
45842   420   CONTINUE
45843         DO 440 I=NSAV+NJET+1,N
45844           IR1=K(I,3)
45845           IR2=N+IR1-NSAV
45846           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45847      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45848           DO 430 J=1,3
45849             P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
45850      &      PLS*P(IR1,J)
45851   430     CONTINUE
45852           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45853   440   CONTINUE
45854       ENDIF
45855
45856 C...Scale momenta for energy conservation.
45857       IF(MOD(MSTJ(3),5).NE.0) THEN
45858         PMS=0D0
45859         PES=0D0
45860         PQS=0D0
45861         DO 450 I=NSAV+NJET+1,N
45862           PMS=PMS+P(I,5)
45863           PES=PES+P(I,4)
45864           PQS=PQS+P(I,5)**2/P(I,4)
45865   450   CONTINUE
45866         IF(PMS.GE.PECM) GOTO 150
45867         NECO=0
45868   460   NECO=NECO+1
45869         PFAC=(PECM-PQS)/(PES-PQS)
45870         PES=0D0
45871         PQS=0D0
45872         DO 480 I=NSAV+NJET+1,N
45873           DO 470 J=1,3
45874             P(I,J)=PFAC*P(I,J)
45875   470     CONTINUE
45876           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45877           PES=PES+P(I,4)
45878           PQS=PQS+P(I,5)**2/P(I,4)
45879   480   CONTINUE
45880         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
45881       ENDIF
45882
45883 C...Origin of produced particles and parton daughter pointers.
45884   490 DO 500 I=NSAV+NJET+1,N
45885         IF(MSTU(16).NE.2) K(I,3)=NSAV+1
45886         IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
45887   500 CONTINUE
45888       DO 510 I=NSAV+1,NSAV+NJET
45889         I1=K(I,3)
45890         K(I1,1)=K(I1,1)+10
45891         IF(MSTU(16).NE.2) THEN
45892           K(I1,4)=NSAV+1
45893           K(I1,5)=NSAV+1
45894         ELSE
45895           K(I1,4)=K(I1,4)-NJET+1
45896           K(I1,5)=K(I1,5)-NJET+1
45897           IF(K(I1,5).LT.K(I1,4)) THEN
45898             K(I1,4)=0
45899             K(I1,5)=0
45900           ENDIF
45901         ENDIF
45902   510 CONTINUE
45903
45904 C...Document independent fragmentation system. Remove copy of jets.
45905       NSAV=NSAV+1
45906       K(NSAV,1)=11
45907       K(NSAV,2)=93
45908       K(NSAV,3)=IP
45909       K(NSAV,4)=NSAV+1
45910       K(NSAV,5)=N-NJET+1
45911       DO 520 J=1,4
45912         P(NSAV,J)=DPS(J)
45913         V(NSAV,J)=V(IP,J)
45914   520 CONTINUE
45915       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45916       V(NSAV,5)=0D0
45917       DO 540 I=NSAV+NJET,N
45918         DO 530 J=1,5
45919           K(I-NJET+1,J)=K(I,J)
45920           P(I-NJET+1,J)=P(I,J)
45921           V(I-NJET+1,J)=V(I,J)
45922   530   CONTINUE
45923   540 CONTINUE
45924       N=N-NJET+1
45925       DO 550 IZ=MSTU90+1,MSTU(90)
45926         MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
45927   550 CONTINUE
45928
45929 C...Boost back particle system. Set production vertices.
45930       IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
45931      &DPS(2)/DPS(4),DPS(3)/DPS(4))
45932       DO 570 I=NSAV+1,N
45933         DO 560 J=1,4
45934           V(I,J)=V(IP,J)
45935   560   CONTINUE
45936   570 CONTINUE
45937
45938       RETURN
45939       END
45940
45941 C*********************************************************************
45942
45943 C...PYDECY
45944 C...Handles the decay of unstable particles.
45945
45946       SUBROUTINE PYDECY(IP)
45947
45948 C...Double precision and integer declarations.
45949       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45950       IMPLICIT INTEGER(I-N)
45951       INTEGER PYK,PYCHGE,PYCOMP
45952 C...Commonblocks.
45953       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45954       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45955       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45956       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45957       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45958 C...Local arrays.
45959       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
45960      &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
45961       CHARACTER CIDC*4
45962       DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
45963
45964 C...Functions: momentum in two-particle decays and four-product.
45965       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
45966       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)
45967
45968 C...Initial values.
45969       NTRY=0
45970       NSAV=N
45971       KFA=IABS(K(IP,2))
45972       KFS=ISIGN(1,K(IP,2))
45973       KC=PYCOMP(KFA)
45974       MSTJ(92)=0
45975
45976 C...Choose lifetime and determine decay vertex.
45977       IF(K(IP,1).EQ.5) THEN
45978         V(IP,5)=0D0
45979       ELSEIF(K(IP,1).NE.4) THEN
45980         V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
45981       ENDIF
45982       DO 100 J=1,4
45983         VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
45984   100 CONTINUE
45985
45986 C...Determine whether decay allowed or not.
45987       MOUT=0
45988       IF(MSTJ(22).EQ.2) THEN
45989         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
45990       ELSEIF(MSTJ(22).EQ.3) THEN
45991         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
45992       ELSEIF(MSTJ(22).EQ.4) THEN
45993         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
45994         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
45995       ENDIF
45996       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
45997         K(IP,1)=4
45998         RETURN
45999       ENDIF
46000
46001 C...Interface to external tau decay library (for tau polarization).
46002       IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
46003
46004 C...Starting values for pointers and momenta.
46005         ITAU=IP
46006         DO 110 J=1,4
46007           PTAU(J)=P(ITAU,J)
46008           PCMTAU(J)=P(ITAU,J)
46009   110   CONTINUE
46010
46011 C...Iterate to find position and code of mother of tau.
46012         IMTAU=ITAU
46013   120   IMTAU=K(IMTAU,3)
46014
46015         IF(IMTAU.EQ.0) THEN
46016 C...If no known origin then impossible to do anything further.
46017           KFORIG=0
46018           IORIG=0
46019
46020         ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
46021 C...If tau -> tau + gamma then add gamma energy and loop.
46022           IF(K(K(IMTAU,4),2).EQ.22) THEN
46023             DO 130 J=1,4
46024               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
46025   130       CONTINUE
46026           ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
46027             DO 140 J=1,4
46028               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
46029   140       CONTINUE
46030           ENDIF
46031           GOTO 120
46032
46033         ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
46034 C...If coming from weak decay of hadron then W is not stored in record,
46035 C...but can be reconstructed by adding neutrino momentum.
46036           KFORIG=-ISIGN(24,K(ITAU,2))
46037           IORIG=0
46038           DO 160 II=K(IMTAU,4),K(IMTAU,5)
46039             IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
46040               DO 150 J=1,4
46041                 PCMTAU(J)=PCMTAU(J)+P(II,J)
46042   150         CONTINUE
46043             ENDIF
46044   160     CONTINUE
46045
46046         ELSE
46047 C...If coming from resonance decay then find latest copy of this
46048 C...resonance (may not completely agree).
46049           KFORIG=K(IMTAU,2)
46050           IORIG=IMTAU
46051           DO 170 II=IMTAU+1,IP-1
46052             IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
46053      &      ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
46054   170     CONTINUE
46055           DO 180 J=1,4
46056             PCMTAU(J)=P(IORIG,J)
46057   180     CONTINUE
46058         ENDIF
46059
46060 C...Boost tau to rest frame of production process (where known)
46061 C...and rotate it to sit along +z axis.
46062         DO 190 J=1,3
46063           DBETAU(J)=PCMTAU(J)/PCMTAU(4)
46064   190   CONTINUE
46065         IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
46066      &  -DBETAU(2),-DBETAU(3))
46067         PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
46068         CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
46069         THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
46070         CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
46071
46072 C...Call tau decay routine (if meaningful) and fill extra info.
46073         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46074           CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
46075           DO 200 II=NSAV+1,NSAV+NDECAY
46076             K(II,1)=1
46077             K(II,3)=IP
46078             K(II,4)=0
46079             K(II,5)=0
46080   200     CONTINUE
46081           N=NSAV+NDECAY
46082         ENDIF
46083
46084 C...Boost back decay tau and decay products.
46085         DO 210 J=1,4
46086           P(ITAU,J)=PTAU(J)
46087   210   CONTINUE
46088         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46089           CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
46090           IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
46091      &    DBETAU(2),DBETAU(3))
46092
46093 C...Skip past ordinary tau decay treatment.
46094           MMAT=0
46095           MBST=0
46096           ND=0
46097           GOTO 630
46098         ENDIF
46099       ENDIF
46100
46101 C...B-Bbar mixing: flip sign of meson appropriately.
46102       MMIX=0
46103       IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
46104         XBBMIX=PARJ(76)
46105         IF(KFA.EQ.531) XBBMIX=PARJ(77)
46106         IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
46107         IF(MMIX.EQ.1) KFS=-KFS
46108       ENDIF
46109
46110 C...Check existence of decay channels. Particle/antiparticle rules.
46111       KCA=KC
46112       IF(MDCY(KC,2).GT.0) THEN
46113         MDMDCY=MDME(MDCY(KC,2),2)
46114         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
46115       ENDIF
46116       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
46117         CALL PYERRM(9,'(PYDECY:) no decay channel defined')
46118         RETURN
46119       ENDIF
46120       IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
46121       IF(KCHG(KC,3).EQ.0) THEN
46122         KFSP=1
46123         KFSN=0
46124         IF(PYR(0).GT.0.5D0) KFS=-KFS
46125       ELSEIF(KFS.GT.0) THEN
46126         KFSP=1
46127         KFSN=0
46128       ELSE
46129         KFSP=0
46130         KFSN=1
46131       ENDIF
46132
46133 C...Sum branching ratios of allowed decay channels.
46134   220 NOPE=0
46135       BRSU=0D0
46136       DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
46137         IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46138      &  KFSN*MDME(IDL,1).NE.3) GOTO 230
46139         IF(MDME(IDL,2).GT.100) GOTO 230
46140         NOPE=NOPE+1
46141         BRSU=BRSU+BRAT(IDL)
46142   230 CONTINUE
46143       IF(NOPE.EQ.0) THEN
46144         CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
46145         RETURN
46146       ENDIF
46147
46148 C...Select decay channel among allowed ones.
46149   240 RBR=BRSU*PYR(0)
46150       IDL=MDCY(KCA,2)-1
46151   250 IDL=IDL+1
46152       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46153      &KFSN*MDME(IDL,1).NE.3) THEN
46154         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46155       ELSEIF(MDME(IDL,2).GT.100) THEN
46156         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46157       ELSE
46158         IDC=IDL
46159         RBR=RBR-BRAT(IDL)
46160         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
46161       ENDIF
46162
46163 C...Start readout of decay channel: matrix element, reset counters.
46164       MMAT=MDME(IDC,2)
46165   260 NTRY=NTRY+1
46166       IF(MOD(NTRY,200).EQ.0) THEN
46167         WRITE(CIDC,'(I4)') IDC
46168 C...Do not print warning for some well-known special cases.
46169         IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
46170      &  CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
46171      &  CIDC)
46172         GOTO 240
46173       ENDIF
46174       IF(NTRY.GT.1000) THEN
46175         CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46176         IF(MSTU(21).GE.1) RETURN
46177       ENDIF
46178       I=N
46179       NP=0
46180       NQ=0
46181       MBST=0
46182       IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
46183       DO 270 J=1,4
46184         PV(1,J)=0D0
46185         IF(MBST.EQ.0) PV(1,J)=P(IP,J)
46186   270 CONTINUE
46187       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
46188       PV(1,5)=P(IP,5)
46189       PS=0D0
46190       PSQ=0D0
46191       MREM=0
46192       MHADDY=0
46193       IF(KFA.GT.80) MHADDY=1
46194 C.. Random flavour and popcorn system memory.
46195       IRNDMO=0
46196       JTMO=0
46197       MSTU(121)=0
46198       MSTU(125)=10
46199
46200 C...Read out decay products. Convert to standard flavour code.
46201       JTMAX=5
46202       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
46203       DO 280 JT=1,JTMAX
46204         IF(JT.LE.5) KP=KFDP(IDC,JT)
46205         IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
46206         IF(KP.EQ.0) GOTO 280
46207         KPA=IABS(KP)
46208         KCP=PYCOMP(KPA)
46209         IF(KPA.GT.80) MHADDY=1
46210         IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
46211           KFP=KP
46212         ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
46213           KFP=KFS*KP
46214         ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
46215           KFP=-KFS*MOD(KFA/10,10)
46216         ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
46217           KFP=KFS*(100*MOD(KFA/10,100)+3)
46218         ELSEIF(KPA.EQ.81) THEN
46219           KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
46220         ELSEIF(KP.EQ.82) THEN
46221           CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
46222           IF(KFP.EQ.0) GOTO 260
46223           KFP=-KFP
46224           IRNDMO=1
46225           MSTJ(93)=1
46226           IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
46227         ELSEIF(KP.EQ.-82) THEN
46228           KFP=MSTU(124)
46229         ENDIF
46230         IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
46231
46232 C...Add decay product to event record or to quark flavour list.
46233         KFPA=IABS(KFP)
46234         KQP=KCHG(KCP,2)
46235         IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
46236           NQ=NQ+1
46237           KFLO(NQ)=KFP
46238 C...set rndmflav popcorn system pointer
46239           IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
46240           MSTJ(93)=2
46241           PSQ=PSQ+PYMASS(KFLO(NQ))
46242         ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
46243      &    MOD(NQ,2).EQ.1) THEN
46244           NQ=NQ-1
46245           PS=PS-P(I,5)
46246           K(I,1)=1
46247           KFI=K(I,2)
46248           CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
46249           IF(K(I,2).EQ.0) GOTO 260
46250           MSTJ(93)=1
46251           P(I,5)=PYMASS(K(I,2))
46252           PS=PS+P(I,5)
46253         ELSE
46254           I=I+1
46255           NP=NP+1
46256           IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
46257           IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
46258           K(I,1)=1+MOD(NQ,2)
46259           IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
46260           IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
46261           K(I,2)=KFP
46262           K(I,3)=IP
46263           K(I,4)=0
46264           K(I,5)=0
46265           P(I,5)=PYMASS(KFP)
46266           PS=PS+P(I,5)
46267         ENDIF
46268   280 CONTINUE
46269
46270 C...Check masses for resonance decays.
46271       IF(MHADDY.EQ.0) THEN
46272         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
46273       ENDIF
46274
46275 C...Choose decay multiplicity in phase space model.
46276   290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
46277         PSP=PS
46278         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
46279         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
46280   300   NTRY=NTRY+1
46281 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
46282         IF(IRNDMO.EQ.0) THEN
46283            MSTU(121)=0
46284            JTMO=0
46285         ELSEIF(IRNDMO.EQ.1) THEN
46286            IRNDMO=2
46287         ELSE
46288            GOTO 260
46289         ENDIF
46290         IF(NTRY.GT.1000) THEN
46291           CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46292           IF(MSTU(21).GE.1) RETURN
46293         ENDIF
46294         IF(MMAT.LE.20) THEN
46295           GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
46296      &    SIN(PARU(2)*PYR(0))
46297           ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
46298           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
46299           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
46300           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
46301           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
46302         ELSE
46303           ND=MMAT-20
46304         ENDIF
46305 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
46306         MSTU(125)=ND-NQ/2
46307         IF(MSTU(121).GT.MSTU(125)) GOTO 300
46308
46309 C...Form hadrons from flavour content.
46310         DO 310 JT=1,NQ
46311           KFL1(JT)=KFLO(JT)
46312   310   CONTINUE
46313         IF(ND.EQ.NP+NQ/2) GOTO 330
46314         DO 320 I=N+NP+1,N+ND-NQ/2
46315 C.. Stick to started popcorn system, else pick side at random
46316           JT=JTMO
46317           IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
46318           CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
46319           IF(K(I,2).EQ.0) GOTO 300
46320           MSTU(125)=MSTU(125)-1
46321           JTMO=0
46322           IF(MSTU(121).GT.0) JTMO=JT
46323           KFL1(JT)=-KFL2
46324   320   CONTINUE
46325   330   JT=2
46326         JT2=3
46327         JT3=4
46328         IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
46329         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
46330      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
46331         IF(JT.EQ.3) JT2=2
46332         IF(JT.EQ.4) JT3=2
46333         CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
46334         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
46335         IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
46336         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
46337
46338 C...Check that sum of decay product masses not too large.
46339         PS=PSP
46340         DO 340 I=N+NP+1,N+ND
46341           K(I,1)=1
46342           K(I,3)=IP
46343           K(I,4)=0
46344           K(I,5)=0
46345           P(I,5)=PYMASS(K(I,2))
46346           PS=PS+P(I,5)
46347   340   CONTINUE
46348         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
46349
46350 C...Rescale energy to subtract off spectator quark mass.
46351       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
46352      &  .AND.NP.GE.3) THEN
46353         PS=PS-P(N+NP,5)
46354         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
46355         DO 350 J=1,5
46356           P(N+NP,J)=PQT*PV(1,J)
46357           PV(1,J)=(1D0-PQT)*PV(1,J)
46358   350   CONTINUE
46359         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46360         ND=NP-1
46361         MREM=1
46362
46363 C...Fully specified final state: check mass broadening effects.
46364       ELSE
46365         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
46366         ND=NP
46367       ENDIF
46368
46369 C...Determine position of grandmother, number of sisters.
46370       NM=0
46371       KFAS=0
46372       MSGN=0
46373       IF(MMAT.EQ.3) THEN
46374         IM=K(IP,3)
46375         IF(IM.LT.0.OR.IM.GE.IP) IM=0
46376         IF(IM.NE.0) KFAM=IABS(K(IM,2))
46377         IF(IM.NE.0) THEN
46378           DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
46379             IF(K(IL,3).EQ.IM) NM=NM+1
46380             IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
46381   360     CONTINUE
46382           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
46383      &    MOD(KFAM/1000,10).NE.0) NM=0
46384           IF(NM.EQ.2) THEN
46385             KFAS=IABS(K(ISIS,2))
46386             IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
46387      &      MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
46388           ENDIF
46389         ENDIF
46390       ENDIF
46391
46392 C...Kinematics of one-particle decays.
46393       IF(ND.EQ.1) THEN
46394         DO 370 J=1,4
46395           P(N+1,J)=P(IP,J)
46396   370   CONTINUE
46397         GOTO 630
46398       ENDIF
46399
46400 C...Calculate maximum weight ND-particle decay.
46401       PV(ND,5)=P(N+ND,5)
46402       IF(ND.GE.3) THEN
46403         WTMAX=1D0/WTCOR(ND-2)
46404         PMAX=PV(1,5)-PS+P(N+ND,5)
46405         PMIN=0D0
46406         DO 380 IL=ND-1,1,-1
46407           PMAX=PMAX+P(N+IL,5)
46408           PMIN=PMIN+P(N+IL+1,5)
46409           WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
46410   380   CONTINUE
46411       ENDIF
46412
46413 C...Find virtual gamma mass in Dalitz decay.
46414   390 IF(ND.EQ.2) THEN
46415       ELSEIF(MMAT.EQ.2) THEN
46416         PMES=4D0*PMAS(11,1)**2
46417         PMRHO2=PMAS(131,1)**2
46418         PGRHO2=PMAS(131,2)**2
46419   400   PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
46420         WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
46421      &  (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
46422      &  ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
46423         IF(WT.LT.PYR(0)) GOTO 400
46424         PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
46425
46426 C...M-generator gives weight. If rejected, try again.
46427       ELSE
46428   410   RORD(1)=1D0
46429         DO 440 IL1=2,ND-1
46430           RSAV=PYR(0)
46431           DO 420 IL2=IL1-1,1,-1
46432             IF(RSAV.LE.RORD(IL2)) GOTO 430
46433             RORD(IL2+1)=RORD(IL2)
46434   420     CONTINUE
46435   430     RORD(IL2+1)=RSAV
46436   440   CONTINUE
46437         RORD(ND)=0D0
46438         WT=1D0
46439         DO 450 IL=ND-1,1,-1
46440           PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
46441      &    (PV(1,5)-PS)
46442           WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46443   450   CONTINUE
46444         IF(WT.LT.PYR(0)*WTMAX) GOTO 410
46445       ENDIF
46446
46447 C...Perform two-particle decays in respective CM frame.
46448   460 DO 480 IL=1,ND-1
46449         PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46450         UE(3)=2D0*PYR(0)-1D0
46451         PHI=PARU(2)*PYR(0)
46452         UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46453         UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46454         DO 470 J=1,3
46455           P(N+IL,J)=PA*UE(J)
46456           PV(IL+1,J)=-PA*UE(J)
46457   470   CONTINUE
46458         P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
46459         PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
46460   480 CONTINUE
46461
46462 C...Lorentz transform decay products to lab frame.
46463       DO 490 J=1,4
46464         P(N+ND,J)=PV(ND,J)
46465   490 CONTINUE
46466       DO 530 IL=ND-1,1,-1
46467         DO 500 J=1,3
46468           BE(J)=PV(IL,J)/PV(IL,4)
46469   500   CONTINUE
46470         GA=PV(IL,4)/PV(IL,5)
46471         DO 520 I=N+IL,N+ND
46472           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46473           DO 510 J=1,3
46474             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46475   510     CONTINUE
46476           P(I,4)=GA*(P(I,4)+BEP)
46477   520   CONTINUE
46478   530 CONTINUE
46479
46480 C...Check that no infinite loop in matrix element weight.
46481       NTRY=NTRY+1
46482       IF(NTRY.GT.800) GOTO 560
46483
46484 C...Matrix elements for omega and phi decays.
46485       IF(MMAT.EQ.1) THEN
46486         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
46487      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
46488      &  +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
46489         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
46490
46491 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
46492       ELSEIF(MMAT.EQ.2) THEN
46493         FOUR12=FOUR(N+1,N+2)
46494         FOUR13=FOUR(N+1,N+3)
46495         WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
46496      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
46497         IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
46498
46499 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
46500 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
46501 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
46502       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
46503         FOUR10=FOUR(IP,IM)
46504         FOUR12=FOUR(IP,N+1)
46505         FOUR02=FOUR(IM,N+1)
46506         PMS1=P(IP,5)**2
46507         PMS0=P(IM,5)**2
46508         PMS2=P(N+1,5)**2
46509         IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
46510         IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
46511      &  PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
46512         HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
46513         HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
46514         IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
46515
46516 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
46517       ELSEIF(MMAT.EQ.4) THEN
46518         HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46519         HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
46520         HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
46521         WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
46522      &  ((1D0-HX3)/(HX1*HX2))**2
46523         IF(WT.LT.2D0*PYR(0)) GOTO 390
46524         IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
46525      &  GOTO 390
46526
46527 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
46528       ELSEIF(MMAT.EQ.41) THEN
46529         HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46530         HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
46531         IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
46532
46533 C...Matrix elements for weak decays (only semileptonic for c and b)
46534       ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46535      &  .AND.ND.EQ.3) THEN
46536         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
46537         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
46538         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46539       ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
46540         DO 550 J=1,4
46541           P(N+NP+1,J)=0D0
46542           DO 540 IS=N+3,N+NP
46543             P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
46544   540     CONTINUE
46545   550   CONTINUE
46546         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
46547         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
46548         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46549       ENDIF
46550
46551 C...Scale back energy and reattach spectator.
46552   560 IF(MREM.EQ.1) THEN
46553         DO 570 J=1,5
46554           PV(1,J)=PV(1,J)/(1D0-PQT)
46555   570   CONTINUE
46556         ND=ND+1
46557         MREM=0
46558       ENDIF
46559
46560 C...Low invariant mass for system with spectator quark gives particle,
46561 C...not two jets. Readjust momenta accordingly.
46562       IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
46563         MSTJ(93)=1
46564         PM2=PYMASS(K(N+2,2))
46565         MSTJ(93)=1
46566         PM3=PYMASS(K(N+3,2))
46567         IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
46568      &  (PARJ(32)+PM2+PM3)**2) GOTO 630
46569         K(N+2,1)=1
46570         KFTEMP=K(N+2,2)
46571         CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
46572         IF(K(N+2,2).EQ.0) GOTO 260
46573         P(N+2,5)=PYMASS(K(N+2,2))
46574         PS=P(N+1,5)+P(N+2,5)
46575         PV(2,5)=P(N+2,5)
46576         MMAT=0
46577         ND=2
46578         GOTO 460
46579       ELSEIF(MMAT.EQ.44) THEN
46580         MSTJ(93)=1
46581         PM3=PYMASS(K(N+3,2))
46582         MSTJ(93)=1
46583         PM4=PYMASS(K(N+4,2))
46584         IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
46585      &  (PARJ(32)+PM3+PM4)**2) GOTO 600
46586         K(N+3,1)=1
46587         KFTEMP=K(N+3,2)
46588         CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
46589         IF(K(N+3,2).EQ.0) GOTO 260
46590         P(N+3,5)=PYMASS(K(N+3,2))
46591         DO 580 J=1,3
46592           P(N+3,J)=P(N+3,J)+P(N+4,J)
46593   580   CONTINUE
46594         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)
46595         HA=P(N+1,4)**2-P(N+2,4)**2
46596         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
46597         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
46598      &  (P(N+1,3)-P(N+2,3))**2
46599         HD=(PV(1,4)-P(N+3,4))**2
46600         HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
46601         HF=HD*HC-HB**2
46602         HG=HD*HC-HA*HB
46603         HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
46604         DO 590 J=1,3
46605           PCOR=HH*(P(N+1,J)-P(N+2,J))
46606           P(N+1,J)=P(N+1,J)+PCOR
46607           P(N+2,J)=P(N+2,J)-PCOR
46608   590   CONTINUE
46609         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)
46610         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)
46611         ND=ND-1
46612       ENDIF
46613
46614 C...Check invariant mass of W jets. May give one particle or start over.
46615   600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46616      &.AND.IABS(K(N+1,2)).LT.10) THEN
46617         PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
46618         MSTJ(93)=1
46619         PM1=PYMASS(K(N+1,2))
46620         MSTJ(93)=1
46621         PM2=PYMASS(K(N+2,2))
46622         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
46623         KFLDUM=INT(1.5D0+PYR(0))
46624         CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
46625         CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
46626         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
46627         PSM=PYMASS(KF1)+PYMASS(KF2)
46628         IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
46629         IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
46630         IF(MMAT.EQ.48) GOTO 390
46631         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
46632         K(N+1,1)=1
46633         KFTEMP=K(N+1,2)
46634         CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
46635         IF(K(N+1,2).EQ.0) GOTO 260
46636         P(N+1,5)=PYMASS(K(N+1,2))
46637         K(N+2,2)=K(N+3,2)
46638         P(N+2,5)=P(N+3,5)
46639         PS=P(N+1,5)+P(N+2,5)
46640         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46641         PV(2,5)=P(N+3,5)
46642         MMAT=0
46643         ND=2
46644         GOTO 460
46645       ENDIF
46646
46647 C...Phase space decay of partons from W decay.
46648   610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
46649         KFLO(1)=K(N+1,2)
46650         KFLO(2)=K(N+2,2)
46651         K(N+1,1)=K(N+3,1)
46652         K(N+1,2)=K(N+3,2)
46653         DO 620 J=1,5
46654           PV(1,J)=P(N+1,J)+P(N+2,J)
46655           P(N+1,J)=P(N+3,J)
46656   620   CONTINUE
46657         PV(1,5)=PMR
46658         N=N+1
46659         NP=0
46660         NQ=2
46661         PS=0D0
46662         MSTJ(93)=2
46663         PSQ=PYMASS(KFLO(1))
46664         MSTJ(93)=2
46665         PSQ=PSQ+PYMASS(KFLO(2))
46666         MMAT=11
46667         GOTO 290
46668       ENDIF
46669
46670 C...Boost back for rapidly moving particle.
46671   630 N=N+ND
46672       IF(MBST.EQ.1) THEN
46673         DO 640 J=1,3
46674           BE(J)=P(IP,J)/P(IP,4)
46675   640   CONTINUE
46676         GA=P(IP,4)/P(IP,5)
46677         DO 660 I=NSAV+1,N
46678           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46679           DO 650 J=1,3
46680             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46681   650     CONTINUE
46682           P(I,4)=GA*(P(I,4)+BEP)
46683   660   CONTINUE
46684       ENDIF
46685
46686 C...Fill in position of decay vertex.
46687       DO 680 I=NSAV+1,N
46688         DO 670 J=1,4
46689           V(I,J)=VDCY(J)
46690   670   CONTINUE
46691         V(I,5)=0D0
46692   680 CONTINUE
46693
46694 C...Set up for parton shower evolution from jets.
46695       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
46696         K(NSAV+1,1)=3
46697         K(NSAV+2,1)=3
46698         K(NSAV+3,1)=3
46699         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46700         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46701         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46702         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46703         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46704         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46705         MSTJ(92)=-(NSAV+1)
46706       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
46707         K(NSAV+2,1)=3
46708         K(NSAV+3,1)=3
46709         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46710         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
46711         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
46712         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46713         MSTJ(92)=NSAV+2
46714       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46715      &  IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
46716         K(NSAV+1,1)=3
46717         K(NSAV+2,1)=3
46718         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46719         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
46720         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
46721         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46722         MSTJ(92)=NSAV+1
46723       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46724      &  IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
46725         MSTJ(92)=NSAV+1
46726       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
46727      &  THEN
46728         K(NSAV+1,1)=3
46729         K(NSAV+2,1)=3
46730         K(NSAV+3,1)=3
46731         KCP=PYCOMP(K(NSAV+1,2))
46732         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
46733         JCON=4
46734         IF(KQP.LT.0) JCON=5
46735         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
46736         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
46737         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
46738         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
46739         MSTJ(92)=NSAV+1
46740       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
46741         K(NSAV+1,1)=3
46742         K(NSAV+3,1)=3
46743         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
46744         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46745         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46746         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
46747         MSTJ(92)=NSAV+1
46748       ENDIF
46749
46750 C...Mark decayed particle; special option for B-Bbar mixing.
46751       IF(K(IP,1).EQ.5) K(IP,1)=15
46752       IF(K(IP,1).LE.10) K(IP,1)=11
46753       IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
46754       K(IP,4)=NSAV+1
46755       K(IP,5)=N
46756
46757       RETURN
46758       END
46759
46760
46761 C*********************************************************************
46762
46763 C...PYDCYK
46764 C...Handles flavour production in the decay of unstable particles
46765 C...and small string clusters.
46766
46767       SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
46768
46769 C...Double precision and integer declarations.
46770       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46771       IMPLICIT INTEGER(I-N)
46772       INTEGER PYK,PYCHGE,PYCOMP
46773 C...Commonblocks.
46774       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46775       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46776       SAVE /PYDAT1/,/PYDAT2/
46777
46778
46779 C.. Call PYKFDI directly if no popcorn option is on
46780       IF(MSTJ(12).LT.2) THEN
46781          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46782          MSTU(124)=KFL3
46783          RETURN
46784       ENDIF
46785
46786       KFL3=0
46787       KF=0
46788       IF(KFL1.EQ.0) RETURN
46789       KF1A=IABS(KFL1)
46790       KF2A=IABS(KFL2)
46791
46792       NSTO=130
46793       NMAX=MIN(MSTU(125),10)
46794
46795 C.. Identify rank 0 cluster qq
46796       IRANK=1
46797       IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
46798
46799       IF(KF2A.GT.0)THEN
46800 C.. Join jets: Fails if store not empty
46801          IF(MSTU(121).GT.0) THEN
46802             MSTU(121)=0
46803             RETURN
46804          ENDIF
46805          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46806       ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
46807 C.. Pick popcorn meson from store, return same qq, decrease store
46808          KF=MSTU(NSTO+MSTU(121))
46809          KFL3=-KFL1
46810          MSTU(121)=MSTU(121)-1
46811       ELSE
46812 C.. Generate new flavour. Then done if no diquark is generated
46813   100    CALL PYKFDI(KFL1,0,KFL3,KF)
46814          IF(MSTU(121).EQ.-1) GOTO 100
46815          MSTU(124)=KFL3
46816          IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
46817
46818 C.. Simple case if no dynamical popcorn suppressions are considered
46819          IF(MSTJ(12).LT.4) THEN
46820             IF(MSTU(121).EQ.0) RETURN
46821             NMES=1
46822             KFPREV=-KFL3
46823             CALL PYKFDI(KFPREV,0,KFL3,KFM)
46824 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
46825             IF(IABS(KFL3).LE.10)THEN
46826                KFL3=-KFPREV
46827                RETURN
46828             ENDIF
46829             GOTO 120
46830          ENDIF
46831
46832 C test output qq against fake Gamma, then return if no popcorn.
46833          GB=2D0
46834          IF(IRANK.NE.0)THEN
46835             CALL PYZDIS(1,2103,5D0,Z)
46836             GB=5D0*(1D0-Z)/Z
46837             IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
46838                MSTU(121)=0
46839                GOTO 100
46840             ENDIF
46841          ENDIF
46842          IF(MSTU(121).EQ.0) RETURN
46843
46844 C..Set store size memory. Pick fake dynamical variables of qq.
46845          NMES=MSTU(121)
46846          CALL PYPTDI(1,PX3,PY3)
46847          X=1D0
46848          POPM=0D0
46849          G=GB
46850          POPG=GB
46851
46852 C.. Pick next popcorn meson, test with fake dynamical variables
46853   110    KFPREV=-KFL3
46854          PX1=-PX3
46855          PY1=-PY3
46856          CALL PYKFDI(KFPREV,0,KFL3,KFM)
46857          IF(MSTU(121).EQ.-1) GOTO 100
46858          CALL PYPTDI(KFL3,PX3,PY3)
46859          PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
46860          CALL PYZDIS(KFPREV,KFL3,PM,Z)
46861          G=(1D0-Z)*(G+PM/Z)
46862          X=(1D0-Z)*X
46863
46864          PTST=1D0
46865          GTST=1D0
46866          RTST=PYR(0)
46867          IF(MSTJ(12).GT.4)THEN
46868             POPMN=SQRT((1D0-X)*(G/X-GB))
46869             POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
46870             PTST=EXP((POPM-POPMN)*PARF(193))
46871             POPM=POPMN
46872          ENDIF
46873          IF(IRANK.NE.0)THEN
46874             POPGN=X*GB
46875             GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
46876             POPG=POPGN
46877          ENDIF
46878          IF(RTST.GT.PTST*GTST)THEN
46879             MSTU(121)=0
46880             IF(RTST.GT.PTST) MSTU(121)=-1
46881             GOTO 100
46882          ENDIF
46883
46884 C.. Store meson
46885   120    IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
46886          IF(MSTU(121).GT.0) GOTO 110
46887
46888 C.. Test accepted system size. If OK set global popcorn size variable.
46889          IF(NMES.GT.NMAX)THEN
46890             KF=0
46891             KFL3=0
46892             RETURN
46893          ENDIF
46894          MSTU(121)=NMES
46895       ENDIF
46896
46897       RETURN
46898       END
46899
46900 C********************************************************************
46901
46902 C...PYKFDI
46903 C...Generates a new flavour pair and combines off a hadron
46904
46905       SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
46906
46907 C...Double precision and integer declarations.
46908       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46909       IMPLICIT INTEGER(I-N)
46910       INTEGER PYK,PYCHGE,PYCOMP
46911 C...Commonblocks.
46912       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46913       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46914       SAVE /PYDAT1/,/PYDAT2/
46915 C...Local arrays.
46916       DIMENSION PD(7)
46917
46918       IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0)  CALL PYKFIN
46919
46920 C...Default flavour values. Input consistency checks.
46921       KF1A=IABS(KFL1)
46922       KF2A=IABS(KFL2)
46923       KFL3=0
46924       KF=0
46925       IF(KF1A.EQ.0) RETURN
46926       IF(KF2A.NE.0)THEN
46927         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
46928         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
46929         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
46930       ENDIF
46931
46932 C...Check if tabulated flavour probabilities are to be used.
46933       IF(MSTJ(15).EQ.1) THEN
46934         IF(MSTJ(12).GE.5)  CALL PYERRM(29,
46935      &        '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
46936      &        ' together with MSTJ(12)>=5 modification')
46937         KTAB1=-1
46938         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
46939         KFL1A=MOD(KF1A/1000,10)
46940         KFL1B=MOD(KF1A/100,10)
46941         KFL1S=MOD(KF1A,10)
46942         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
46943      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
46944         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
46945         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
46946         KTAB2=0
46947         IF(KF2A.NE.0) THEN
46948           KTAB2=-1
46949           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
46950           KFL2A=MOD(KF2A/1000,10)
46951           KFL2B=MOD(KF2A/100,10)
46952           KFL2S=MOD(KF2A,10)
46953           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
46954      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
46955           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
46956         ENDIF
46957         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
46958       ENDIF
46959
46960 C.. Recognize rank 0 diquark case
46961   100 IRANK=1
46962       KFDIQ=MAX(KF1A,KF2A)
46963       IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
46964
46965 C.. Join two flavours to meson or baryon. Test for popcorn.
46966       IF(KF2A.GT.0)THEN
46967         MBARY=0
46968         IF(KFDIQ.GT.10) THEN
46969           IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
46970      &         CALL PYNMES(KFDIQ)
46971           IF(MSTU(121).NE.0) THEN
46972              MSTU(121)=0
46973              RETURN
46974           ENDIF
46975           MBARY=2
46976         ENDIF
46977         KFQOLD=KF1A
46978         KFQVER=KF2A
46979         GOTO 130
46980       ENDIF
46981
46982 C.. Separate incoming flavours, curtain flavour consistency check
46983       KFIN=KFL1
46984       KFQOLD=KF1A
46985       KFQPOP=KF1A/10000
46986       IF(KF1A.GT.10)THEN
46987          KFIN=-KFL1
46988          KFL1A=MOD(KF1A/1000,10)
46989          KFL1B=MOD(KF1A/100,10)
46990          IF(IRANK.EQ.0)THEN
46991             QAWT=1D0
46992             IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
46993             IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
46994             KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
46995          ENDIF
46996          IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
46997              MSTU(121)=0
46998              RETURN
46999           ENDIF
47000          KFQOLD=KFL1A+KFL1B-KFQPOP
47001       ENDIF
47002
47003 C...Meson/baryon choice. Set number of mesons if starting a popcorn
47004 C...system.
47005   110 MBARY=0
47006       IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
47007          IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
47008             MBARY=1
47009             CALL PYNMES(0)
47010          ENDIF
47011       ELSEIF(KF1A.GT.10)THEN
47012          MBARY=2
47013          IF(IRANK.EQ.0) CALL PYNMES(KF1A)
47014          IF(MSTU(121).GT.0) MBARY=-1
47015       ENDIF
47016
47017 C..x->H+q: Choose single vertex quark. Jump to form hadron.
47018       IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
47019          KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
47020          KFL3=ISIGN(KFQVER,-KFIN)
47021          GOTO 130
47022       ENDIF
47023
47024 C..x->H+qq: (IDW=proper PARF position for diquark weights)
47025       IDW=160
47026       IF(MBARY.EQ.1)THEN
47027          IF(MSTU(121).EQ.0) IDW=150
47028          SQWT=PARF(IDW+1)
47029          IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
47030          KFQPOP=1+INT((2D0+SQWT)*PYR(0))
47031 C..   Shift to s-curtain parameters if needed
47032          IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
47033             PARF(194)=PARF(138)*PARF(139)
47034             PARF(193)=PARJ(8)+PARJ(9)
47035          ENDIF
47036       ENDIF
47037
47038 C.. x->H+qq: Get vertex quark
47039       IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47040          IDW=MSTU(122)
47041          MSTU(121)=MSTU(121)-1
47042          IF(IDW.EQ.170) THEN
47043             IF(MSTU(121).EQ.0)THEN
47044                IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
47045             ELSE
47046                IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
47047             ENDIF
47048          ELSE
47049             IF(MSTU(121).EQ.0)THEN
47050                IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
47051             ELSE
47052                IPOS=3*5+5*4+MIN(KFQOLD-1,4)
47053             ENDIF
47054          ENDIF
47055          IPOS=200+30*IPOS+1
47056
47057          IMES=-1
47058          RMES=PYR(0)*PARF(194)
47059   120    IMES=IMES+1
47060          RMES=RMES-PARF(IPOS+IMES)
47061          IF(IMES.EQ.30) THEN
47062             MSTU(121)=-1
47063             KF=-111
47064             RETURN
47065          ENDIF
47066          IF(RMES.GT.0D0) GOTO 120
47067          KMUL=IMES/5
47068          KFJ=2*KMUL+1
47069          IF(KMUL.EQ.2) KFJ=10003
47070          IF(KMUL.EQ.3) KFJ=10001
47071          IF(KMUL.EQ.4) KFJ=20003
47072          IF(KMUL.EQ.5) KFJ=5
47073          IDIAG=0
47074          KFQVER=MOD(IMES,5)+1
47075          IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
47076          IF(KFQVER.GT.3)THEN
47077             IDIAG=KFQVER-3
47078             KFQVER=KFQOLD
47079          ENDIF
47080       ELSE
47081          IF(MBARY.EQ.-1) IDW=170
47082          SQWT=PARF(IDW+2)
47083          IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
47084          IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
47085          KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
47086          IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
47087             KFQVER=KFQPOP
47088             IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
47089          ENDIF
47090       ENDIF
47091
47092 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
47093       KFLDS=3
47094       IF(KFQPOP.NE.KFQVER)THEN
47095          SWT=PARF(IDW+7)
47096          IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
47097          IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
47098          IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
47099       ENDIF
47100       KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
47101      &      +10000*KFQPOP
47102       KFL3=ISIGN(KFDIQ,KFIN)
47103
47104 C..x->M+y: flavour for meson.
47105   130 IF(MBARY.LE.0)THEN
47106         KFLA=MAX(KFQOLD,KFQVER)
47107         KFLB=MIN(KFQOLD,KFQVER)
47108         KFS=ISIGN(1,KFL1)
47109         IF(KFLA.NE.KFQOLD) KFS=-KFS
47110 C... Form meson, with spin and flavour mixing for diagonal states.
47111         IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47112            IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
47113            IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
47114            RETURN
47115         ENDIF
47116         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
47117         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
47118         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
47119         IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
47120           IF(PYR(0).LT.PARJ(14)) KMUL=2
47121         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
47122           RMUL=PYR(0)
47123           IF(RMUL.LT.PARJ(15)) KMUL=3
47124           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
47125           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
47126         ENDIF
47127         KFLS=3
47128         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
47129         IF(KMUL.EQ.5) KFLS=5
47130         IF(KFLA.NE.KFLB)THEN
47131           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
47132         ELSE
47133           RMIX=PYR(0)
47134           IMIX=2*KFLA+10*KMUL
47135           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
47136      &    INT(RMIX+PARF(IMIX)))+KFLS
47137           IF(KFLA.GE.4) KF=110*KFLA+KFLS
47138         ENDIF
47139         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
47140         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
47141
47142 C..Optional extra suppression of eta and eta'.
47143 C..Allow shift to qq->B+q in old version (set IRANK to 0)
47144         IF(KF.EQ.221.OR.KF.EQ.331)THEN
47145            IF(PYR(0).GT.PARJ(25+KF/300))THEN
47146               IF(KF2A.GT.0) GOTO 130
47147               IF(MSTJ(12).LT.4) IRANK=0
47148               GOTO 110
47149            ENDIF
47150         ENDIF
47151         MSTU(121)=0
47152
47153 C.. x->B+y: Flavour for baryon
47154       ELSE
47155         KFLA=KFQVER
47156         IF(KF1A.LE.10) KFLA=KFQOLD
47157         KFLB=MOD(KFDIQ/1000,10)
47158         KFLC=MOD(KFDIQ/100,10)
47159         KFLDS=MOD(KFDIQ,10)
47160         KFLD=MAX(KFLA,KFLB,KFLC)
47161         KFLF=MIN(KFLA,KFLB,KFLC)
47162         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47163
47164 C...  SU(6) factors for formation of baryon.
47165         KBARY=3
47166         KDMAX=5
47167         KFLG=KFLB
47168         IF(KFLB.NE.KFLC)THEN
47169            KBARY=2*KFLDS-1
47170            KDMAX=1+KFLDS/2
47171            IF(KFLB.GT.2) KDMAX=KDMAX+2
47172         ENDIF
47173         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
47174            KBARY=KBARY+1
47175            KFLG=KFLA
47176         ENDIF
47177
47178         SU6MAX=PARF(140+KDMAX)
47179         SU6DEC=PARJ(18)
47180         SU6S  =PARF(146)
47181         IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
47182            SU6MAX=1D0
47183            SU6DEC=1D0
47184            SU6S  =1D0
47185         ENDIF
47186         SU6OCT=PARF(60+KBARY)
47187         IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
47188            SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
47189            IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
47190         ELSE
47191            IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
47192         ENDIF
47193         SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
47194
47195 C..   SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
47196         IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
47197            MSTU(121)=0
47198            IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
47199            GOTO 110
47200         ENDIF
47201
47202 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
47203         KSIG=1
47204         KFLS=2
47205         IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
47206         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
47207           KSIG=KFLDS/3
47208           IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
47209         ENDIF
47210         KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
47211         IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
47212       ENDIF
47213       RETURN
47214
47215 C...Use tabulated probabilities to select new flavour and hadron.
47216   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
47217         KT3L=1
47218         KT3U=6
47219       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
47220         KT3L=1
47221         KT3U=6
47222       ELSEIF(KTAB2.EQ.0) THEN
47223         KT3L=1
47224         KT3U=22
47225       ELSE
47226         KT3L=KTAB2
47227         KT3U=KTAB2
47228       ENDIF
47229       RFL=0D0
47230       DO 160 KTS=0,2
47231         DO 150 KT3=KT3L,KT3U
47232           RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
47233   150   CONTINUE
47234   160 CONTINUE
47235       RFL=PYR(0)*RFL
47236       DO 180 KTS=0,2
47237         KTABS=KTS
47238         DO 170 KT3=KT3L,KT3U
47239           KTAB3=KT3
47240           RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
47241           IF(RFL.LE.0D0) GOTO 190
47242   170   CONTINUE
47243   180 CONTINUE
47244   190 CONTINUE
47245
47246 C...Reconstruct flavour of produced quark/diquark.
47247       IF(KTAB3.LE.6) THEN
47248         KFL3A=KTAB3
47249         KFL3B=0
47250         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
47251       ELSE
47252         KFL3A=1
47253         IF(KTAB3.GE.8) KFL3A=2
47254         IF(KTAB3.GE.11) KFL3A=3
47255         IF(KTAB3.GE.16) KFL3A=4
47256         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
47257         KFL3=1000*KFL3A+100*KFL3B+1
47258         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
47259      &  KFL3+2
47260         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
47261       ENDIF
47262
47263 C...Reconstruct meson code.
47264       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
47265      &KFL3B.NE.0)) THEN
47266         RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47267      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
47268         KF=110+2*KTABS+1
47269         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
47270         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47271      &  25*KTABS)) KF=330+2*KTABS+1
47272       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
47273         KFLA=MAX(KTAB1,KTAB3)
47274         KFLB=MIN(KTAB1,KTAB3)
47275         KFS=ISIGN(1,KFL1)
47276         IF(KFLA.NE.KF1A) KFS=-KFS
47277         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47278       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
47279         KFS=ISIGN(1,KFL1)
47280         IF(KFL1A.EQ.KFL3A) THEN
47281           KFLA=MAX(KFL1B,KFL3B)
47282           KFLB=MIN(KFL1B,KFL3B)
47283           IF(KFLA.NE.KFL1B) KFS=-KFS
47284         ELSEIF(KFL1A.EQ.KFL3B) THEN
47285           KFLA=KFL3A
47286           KFLB=KFL1B
47287           KFS=-KFS
47288         ELSEIF(KFL1B.EQ.KFL3A) THEN
47289           KFLA=KFL1A
47290           KFLB=KFL3B
47291         ELSEIF(KFL1B.EQ.KFL3B) THEN
47292           KFLA=MAX(KFL1A,KFL3A)
47293           KFLB=MIN(KFL1A,KFL3A)
47294           IF(KFLA.NE.KFL1A) KFS=-KFS
47295         ELSE
47296           CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
47297           GOTO 100
47298         ENDIF
47299         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47300
47301 C...Reconstruct baryon code.
47302       ELSE
47303         IF(KTAB1.GE.7) THEN
47304           KFLA=KFL3A
47305           KFLB=KFL1A
47306           KFLC=KFL1B
47307         ELSE
47308           KFLA=KFL1A
47309           KFLB=KFL3A
47310           KFLC=KFL3B
47311         ENDIF
47312         KFLD=MAX(KFLA,KFLB,KFLC)
47313         KFLF=MIN(KFLA,KFLB,KFLC)
47314         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47315         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
47316         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
47317       ENDIF
47318
47319 C...Check that constructed flavour code is an allowed one.
47320       IF(KFL2.NE.0) KFL3=0
47321       KC=PYCOMP(KF)
47322       IF(KC.EQ.0) THEN
47323         CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
47324      &  'failed')
47325         GOTO 100
47326       ENDIF
47327
47328       RETURN
47329       END
47330
47331 C*********************************************************************
47332
47333 C...PYNMES
47334 C...Generates number of popcorn mesons and stores some relevant
47335 C...parameters.
47336
47337       SUBROUTINE PYNMES(KFDIQ)
47338
47339 C...Double precision and integer declarations.
47340       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47341       IMPLICIT INTEGER(I-N)
47342       INTEGER PYK,PYCHGE,PYCOMP
47343 C...Commonblocks.
47344       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47345       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47346       SAVE /PYDAT1/,/PYDAT2/
47347
47348       MSTU(121)=0
47349       IF(MSTJ(12).LT.2) RETURN
47350
47351 C..Old version: Get 1 or 0 popcorn mesons
47352       IF(MSTJ(12).LT.5)THEN
47353          POPWT=PARF(131)
47354          IF(KFDIQ.NE.0) THEN
47355             KFDIQA=IABS(KFDIQ)
47356             KFA=MOD(KFDIQA/1000,10)
47357             KFB=MOD(KFDIQA/100,10)
47358             KFS=MOD(KFDIQA,10)
47359             POPWT=PARF(132)
47360             IF(KFA.EQ.3) POPWT=PARF(133)
47361             IF(KFB.EQ.3) POPWT=PARF(134)
47362             IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
47363          ENDIF
47364          MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
47365          RETURN
47366       ENDIF
47367
47368 C..New version: Store popcorn- or rank 0 diquark parameters
47369       MSTU(122)=170
47370       PARF(193)=PARJ(8)
47371       PARF(194)=PARF(139)
47372       IF(KFDIQ.NE.0) THEN
47373          MSTU(122)=180
47374          PARF(193)=PARJ(10)
47375          PARF(194)=PARF(140)
47376       ENDIF
47377       IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
47378          IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
47379      &        '(PYNMES:) Neglecting too large popcorn possibility')
47380          RETURN
47381       ENDIF
47382
47383 C..New version: Get number of popcorn mesons
47384   100 RTST=PYR(0)
47385       MSTU(121)=-1
47386   110 MSTU(121)=MSTU(121)+1
47387       RTST=RTST/PARF(194)
47388       IF(RTST.LT.1D0) GOTO 110
47389       IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
47390      &     (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
47391       RETURN
47392       END
47393
47394 C***************************************************************
47395
47396 C...PYKFIN
47397 C...Precalculates a set of diquark and popcorn weights.
47398
47399       SUBROUTINE PYKFIN
47400
47401 C...Double precision and integer declarations.
47402       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47403       IMPLICIT INTEGER(I-N)
47404       INTEGER PYK,PYCHGE,PYCOMP
47405 C...Commonblocks.
47406       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47407       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47408       SAVE /PYDAT1/,/PYDAT2/
47409
47410       DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
47411
47412
47413       MSTU(123)=1
47414 C..Diquark indices for dimensional variables
47415       IUD1=1
47416       IUU1=2
47417       IUS0=3
47418       ISU0=4
47419       IUS1=5
47420       ISU1=6
47421       ISS1=7
47422
47423 C.. *** SU(6) factors **
47424 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
47425       PARF(146)=1D0
47426       IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
47427       IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
47428      &     '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
47429       DO 100 I=1,6
47430          SU6(I)=PARF(60+I)
47431          SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
47432   100 CONTINUE
47433       SU6(8)=SU6(2)*4/(3*PARF(146)+1)
47434       SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
47435       DO 110 I=1,6
47436          SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
47437          SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
47438   110 CONTINUE
47439
47440 C..SU(6)max            q       q'     s,c,b
47441       SU6MUD    =MAX(SU6(1) ,       SU6(8) )
47442       SU6M(IUD1)=MAX(SU6(5) ,       SU6(12))
47443       SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
47444       SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
47445       SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
47446       SU6M(IUS0)=SU6M(ISU0)
47447       SU6M(ISS1)=SU6M(IUU1)
47448       SU6M(IUS1)=SU6M(ISU1)
47449
47450 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
47451       PARF(141)=SU6MUD
47452       PARF(142)=SU6M(IUD1)
47453       PARF(143)=SU6M(ISU0)
47454       PARF(144)=SU6M(ISU1)
47455       PARF(145)=SU6M(ISS1)
47456
47457 C..diquark SU(6) survival =
47458 C..sum over quark (quark tunnel weight)*(SU(6)).
47459       PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
47460       DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
47461       DMB(IUS0)=DMB(ISU0)
47462       DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
47463       DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
47464       DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
47465       DMB(IUS1)=DMB(ISU1)
47466       DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
47467
47468 C.. *** Tunneling factors for Diquark production***
47469 C.. T: half a curtain pair = sqrt(curtain pair factor)
47470       IF(MSTJ(12).GE.5) THEN
47471          PMUD0=PYMASS(2101)
47472          PMUD1=PYMASS(2103)-PMUD0
47473          PMUS0=PYMASS(3201)-PMUD0
47474          PMUS1=PYMASS(3203)-PMUS0-PMUD0
47475          PMSS1=PYMASS(3303)-PMUS0-PMUD0
47476          QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
47477          QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
47478          QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
47479          QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
47480          QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
47481          QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
47482          QBB(IUD1)=QBB(IUU1)
47483       ELSE
47484          PAR2M=SQRT(PARJ(2))
47485          PAR3M=SQRT(PARJ(3))
47486          PAR4M=SQRT(PARJ(4))
47487          QBB(ISU0)=PAR2M*PAR3M
47488          QBB(IUS0)=PAR3M
47489          QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
47490          QBB(IUU1)=PAR4M
47491          QBB(ISU1)=PAR4M*QBB(ISU0)
47492          QBB(IUS1)=PAR4M*QBB(IUS0)
47493          QBB(IUD1)=PAR4M
47494       ENDIF
47495
47496 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
47497       QBM(ISU0)=QBB(ISU0)
47498       QBM(IUS0)=PARJ(2)*QBB(IUS0)
47499       QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
47500       QBM(IUU1)=6D0*QBB(IUU1)
47501       QBM(ISU1)=3D0*QBB(ISU1)
47502       QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
47503       QBM(IUD1)=3D0*QBB(IUD1)
47504
47505 C.. Combine T and tau to diquark weight for q-> B+B+..
47506       DO 120 I=1,7
47507          QBB(I)=QBB(I)*QBM(I)
47508   120 CONTINUE
47509
47510       IF(MSTJ(12).GE.5)THEN
47511 C..New version: tau  for rank 0 diquark.
47512          DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
47513          DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
47514          DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
47515          DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
47516          DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
47517          DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
47518          DMB(7+IUD1)=DMB(7+IUU1)/2D0
47519
47520 C..New version: curtain flavour ratios.
47521 C.. s/u for q->B+M+...
47522 C.. s/u for rank 0 diquark: su -> ...M+B+...
47523 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47524          WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47525          PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47526          WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
47527          PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
47528          PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
47529      &        (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
47530       ELSE
47531 C..Old version: reset unused rank 0 diquark weights and
47532 C..             unused diquark SU(6) survival weights
47533          DO 130 I=1,7
47534             IF(MSTJ(12).LT.3) DMB(I)=1D0
47535             DMB(7+I)=1D0
47536   130    CONTINUE
47537
47538 C..Old version: Shuffle PARJ(7) into tau
47539          QBM(IUS0)=QBM(IUS0)*PARJ(7)
47540          QBM(ISS1)=QBM(ISS1)*PARJ(7)
47541          QBM(IUS1)=QBM(IUS1)*PARJ(7)
47542
47543 C..Old version: curtain flavour ratios.
47544 C.. s/u for q->B+M+...
47545 C.. s/u for rank 0 diquark: su -> ...M+B+...
47546 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47547          WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47548          PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47549          PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
47550          PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
47551       ENDIF
47552
47553 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
47554 C..  rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
47555       DO 140 I=1,7
47556          DMB(7+I)=DMB(7+I)*DMB(I)
47557          DMB(I)=DMB(I)*QBM(I)
47558          QBM(I)=QBM(I)*SU6M(I)/SU6MUD
47559          QBB(I)=QBB(I)*SU6M(I)/SU6MUD
47560   140 CONTINUE
47561
47562 C.. *** Popcorn factors ***
47563
47564       IF(MSTJ(12).LT.5)THEN
47565 C.. Old version: Resulting popcorn weights.
47566          PARF(138)=PARJ(6)
47567          WS=PARF(135)*PARF(138)
47568          WQ=WU*PARJ(5)/3D0
47569          PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
47570          PARF(133)=WQ*
47571      &        (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
47572          PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
47573          PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
47574      &                 WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
47575      &        (1D0+QBB(IUD1)+QBB(IUU1)+
47576      &        2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
47577       ELSE
47578 C..New version: Store weights for popcorn mesons,
47579 C..get prel. popcorn weights.
47580          DO 150 IPOS=201,1400
47581             PARF(IPOS)=0D0
47582   150    CONTINUE
47583          DO 160 I=138,140
47584             PARF(I)=0D0
47585   160    CONTINUE
47586          IPOS=200
47587          PARF(193)=PARJ(8)
47588          DO 240 MR=0,7,7
47589            IF(MR.EQ.7) PARF(193)=PARJ(10)
47590            SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
47591      &          (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47592            QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47593            DO 230 NMES=0,1
47594              IF(NMES.EQ.1) SQWT=PARJ(2)
47595              DO 220 KFQPOP=1,4
47596                IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
47597                IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
47598                   SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
47599                   QQWT=0.5D0
47600                   IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
47601                   IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
47602                ENDIF
47603                DO 210 KFQOLD =1,5
47604                   IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
47605                   IF(NMES.EQ.1) THEN
47606                      IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
47607                      IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
47608                   ENDIF
47609                   WTTOT=0D0
47610                   WTFAIL=0D0
47611       DO 190 KMUL=0,5
47612          PJWT=PARJ(12+KMUL)
47613          IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
47614          IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
47615          IF(PJWT.LE.0D0) GOTO 190
47616          IF(PJWT.GT.1D0) PJWT=1D0
47617          IMES=5*KMUL
47618          IMIX=2*KFQOLD+10*KMUL
47619          KFJ=2*KMUL+1
47620          IF(KMUL.EQ.2) KFJ=10003
47621          IF(KMUL.EQ.3) KFJ=10001
47622          IF(KMUL.EQ.4) KFJ=20003
47623          IF(KMUL.EQ.5) KFJ=5
47624          DO 180 KFQVER =1,3
47625             KFLA=MAX(KFQOLD,KFQVER)
47626             KFLB=MIN(KFQOLD,KFQVER)
47627             SWT=PARJ(11+KFLA/3+KFLA/4)
47628             IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
47629             SWT=SWT*PJWT
47630             QWT=SQWT/(2D0+SQWT)
47631             IF(KFQVER.LT.3)THEN
47632                IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
47633                IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
47634             ENDIF
47635             IF(KFQVER.NE.KFQOLD)THEN
47636                IMES=IMES+1
47637                KFM=100*KFLA+10*KFLB+KFJ
47638                PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47639                PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
47640                WTTOT=WTTOT+PARF(IPOS+IMES)
47641             ELSE
47642                DO 170 ID=3,5
47643                   IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
47644                   IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
47645                   IF(ID.EQ.5) DWT=PARF(IMIX)
47646                   KFM=110*(ID-2)+KFJ
47647                   PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47648                   PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
47649                   IF(KMUL.EQ.0.AND.ID.GT.3) THEN
47650                      WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
47651                      PARF(IPOS+5*KMUL+ID)=
47652      &                    PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
47653                   ENDIF
47654                   WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
47655   170          CONTINUE
47656             ENDIF
47657   180    CONTINUE
47658   190 CONTINUE
47659                   DO 200 IMES=1,30
47660                      PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
47661   200             CONTINUE
47662                   IF(MR.EQ.7) PARF(140)=
47663      &                 MAX(PARF(140),WTTOT/(1D0-WTFAIL))
47664                   IF(MR.EQ.0) PARF(139-KFQPOP/3)=
47665      &                 MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
47666                   IPOS=IPOS+30
47667   210           CONTINUE
47668   220         CONTINUE
47669   230       CONTINUE
47670   240    CONTINUE
47671          IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
47672          MSTU(121)=0
47673
47674       ENDIF
47675
47676 C..Recombine diquark weights to flavour and spin ratios
47677       PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
47678      &        (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
47679       PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
47680       PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
47681       PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
47682       PARF(155)=QBB(ISU1)/QBB(ISU0)
47683       PARF(156)=QBB(IUS1)/QBB(IUS0)
47684       PARF(157)=QBB(IUD1)
47685
47686       PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
47687      &        (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
47688       PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
47689       PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
47690       PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
47691       PARF(165)=QBM(ISU1)/QBM(ISU0)
47692       PARF(166)=QBM(IUS1)/QBM(IUS0)
47693       PARF(167)=QBM(IUD1)
47694
47695       PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
47696      &        (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
47697       PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
47698       PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
47699       PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
47700       PARF(175)=DMB(ISU1)/DMB(ISU0)
47701       PARF(176)=DMB(IUS1)/DMB(IUS0)
47702       PARF(177)=DMB(IUD1)
47703
47704       PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
47705       PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
47706       PARF(187)=DMB(7+IUD1)
47707
47708       RETURN
47709       END
47710
47711
47712 C*********************************************************************
47713
47714 C...PYPTDI
47715 C...Generates transverse momentum according to a Gaussian.
47716
47717       SUBROUTINE PYPTDI(KFL,PX,PY)
47718
47719 C...Double precision and integer declarations.
47720       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47721       IMPLICIT INTEGER(I-N)
47722       INTEGER PYK,PYCHGE,PYCOMP
47723 C...Commonblocks.
47724       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47725       SAVE /PYDAT1/
47726
47727 C...Generate p_T and azimuthal angle, gives p_x and p_y.
47728       KFLA=IABS(KFL)
47729       PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
47730       IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
47731       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
47732       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
47733       PHI=PARU(2)*PYR(0)
47734       PX=PT*COS(PHI)
47735       PY=PT*SIN(PHI)
47736
47737       RETURN
47738       END
47739
47740 C*********************************************************************
47741
47742 C...PYZDIS
47743 C...Generates the longitudinal splitting variable z.
47744
47745       SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
47746
47747 C...Double precision and integer declarations.
47748       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47749       IMPLICIT INTEGER(I-N)
47750       INTEGER PYK,PYCHGE,PYCOMP
47751 C...Commonblocks.
47752       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47753       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47754       SAVE /PYDAT1/,/PYDAT2/
47755
47756 C...Check if heavy flavour fragmentation.
47757       KFLA=IABS(KFL1)
47758       KFLB=IABS(KFL2)
47759       KFLH=KFLA
47760       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
47761
47762 C...Lund symmetric scaling function: determine parameters of shape.
47763       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
47764      &MSTJ(11).GE.4) THEN
47765         FA=PARJ(41)
47766         IF(MSTJ(91).EQ.1) FA=PARJ(43)
47767         IF(KFLB.GE.10) FA=FA+PARJ(45)
47768         FBB=PARJ(42)
47769         IF(MSTJ(91).EQ.1) FBB=PARJ(44)
47770         FB=FBB*PR
47771         FC=1D0
47772         IF(KFLA.GE.10) FC=FC-PARJ(45)
47773         IF(KFLB.GE.10) FC=FC+PARJ(45)
47774         IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
47775           FRED=PARJ(46)
47776           IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
47777           FC=FC+FRED*FBB*PARF(100+KFLH)**2
47778         ENDIF
47779         MC=1
47780         IF(ABS(FC-1D0).GT.0.01D0) MC=2
47781
47782 C...Determine position of maximum. Special cases for a = 0 or a = c.
47783         IF(FA.LT.0.02D0) THEN
47784           MA=1
47785           ZMAX=1D0
47786           IF(FC.GT.FB) ZMAX=FB/FC
47787         ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
47788           MA=2
47789           ZMAX=FB/(FB+FC)
47790         ELSE
47791           MA=3
47792           ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
47793           IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
47794         ENDIF
47795
47796 C...Subdivide z range if distribution very peaked near endpoint.
47797         MMAX=2
47798         IF(ZMAX.LT.0.1D0) THEN
47799           MMAX=1
47800           ZDIV=2.75D0*ZMAX
47801           IF(MC.EQ.1) THEN
47802             FINT=1D0-LOG(ZDIV)
47803           ELSE
47804             ZDIVC=ZDIV**(1D0-FC)
47805             FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
47806           ENDIF
47807         ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
47808           MMAX=3
47809           FSCB=SQRT(4D0+(FC/FB)**2)
47810           ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
47811           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
47812           ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
47813           FINT=1D0+FB*(1D0-ZDIV)
47814         ENDIF
47815
47816 C...Choice of z, preweighted for peaks at low or high z.
47817   100   Z=PYR(0)
47818         FPRE=1D0
47819         IF(MMAX.EQ.1) THEN
47820           IF(FINT*PYR(0).LE.1D0) THEN
47821             Z=ZDIV*Z
47822           ELSEIF(MC.EQ.1) THEN
47823             Z=ZDIV**Z
47824             FPRE=ZDIV/Z
47825           ELSE
47826             Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
47827             FPRE=(ZDIV/Z)**FC
47828           ENDIF
47829         ELSEIF(MMAX.EQ.3) THEN
47830           IF(FINT*PYR(0).LE.1D0) THEN
47831             Z=ZDIV+LOG(Z)/FB
47832             FPRE=EXP(FB*(Z-ZDIV))
47833           ELSE
47834             Z=ZDIV+Z*(1D0-ZDIV)
47835           ENDIF
47836         ENDIF
47837
47838 C...Weighting according to correct formula.
47839         IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
47840         FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
47841         IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
47842         FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
47843         IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
47844
47845 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
47846       ELSE
47847         FC=PARJ(50+MAX(1,KFLH))
47848         IF(MSTJ(91).EQ.1) FC=PARJ(59)
47849   110   Z=PYR(0)
47850         IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
47851           IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
47852         ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
47853           IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
47854      &    GOTO 110
47855         ELSE
47856           IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
47857           IF(FC.LT.0D0) Z=Z**(-1D0/FC)
47858         ENDIF
47859       ENDIF
47860
47861       RETURN
47862       END
47863
47864 C*********************************************************************
47865
47866 C...PYSHOW
47867 C...Generates timelike parton showers from given partons.
47868
47869       SUBROUTINE PYSHOW(IP1,IP2,QMAX)
47870
47871 C...Double precision and integer declarations.
47872       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47873       IMPLICIT INTEGER(I-N)
47874       INTEGER PYK,PYCHGE,PYCOMP
47875 C...Parameter statement to help give large particle numbers.
47876       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47877      &KEXCIT=4000000,KDIMEN=5000000)
47878 C...Commonblocks.
47879       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47880       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47881       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47882       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47883 C...Local arrays.
47884       DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
47885      &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
47886      &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
47887      &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
47888      &IREF(1000)
47889
47890 C...Check that QMAX not too low.
47891       IF(MSTJ(41).LE.0) THEN
47892         RETURN
47893       ELSEIF(MSTJ(41).EQ.1) THEN
47894         IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
47895       ELSE
47896         IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
47897      &  RETURN
47898       ENDIF
47899
47900 C...Initialization of cutoff masses etc.
47901       DO 100 IFL=0,40
47902         ISCOL(IFL)=0
47903         ISCHG(IFL)=0
47904         KSH(IFL)=0
47905   100 CONTINUE
47906       ISCOL(21)=1
47907       KSH(21)=1
47908       PMTH(1,21)=PYMASS(21)
47909       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
47910       PMTH(3,21)=2D0*PMTH(2,21)
47911       PMTH(4,21)=PMTH(3,21)
47912       PMTH(5,21)=PMTH(3,21)
47913       PMTH(1,22)=PYMASS(22)
47914       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
47915       PMTH(3,22)=2D0*PMTH(2,22)
47916       PMTH(4,22)=PMTH(3,22)
47917       PMTH(5,22)=PMTH(3,22)
47918       PMQTH1=PARJ(82)
47919       IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
47920       PMQT1E=MIN(PMQTH1,PARJ(90))
47921       PMQTH2=PMTH(2,21)
47922       IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
47923       PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
47924       DO 110 IFL=1,5
47925         ISCOL(IFL)=1
47926         IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47927         KSH(IFL)=1
47928         PMTH(1,IFL)=PYMASS(IFL)
47929         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
47930         PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
47931         PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
47932         PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
47933   110 CONTINUE
47934       DO 120 IFL=11,15,2
47935         IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47936         IF(MSTJ(41).GE.2) KSH(IFL)=1
47937         PMTH(1,IFL)=PYMASS(IFL)
47938         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
47939         PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
47940         PMTH(4,IFL)=PMTH(3,IFL)
47941         PMTH(5,IFL)=PMTH(3,IFL)
47942   120 CONTINUE
47943       PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
47944       ALAMS=PARJ(81)**2
47945       ALFM=LOG(PT2MIN/ALAMS)
47946
47947 C...Store positions of shower initiating partons.
47948       MPSPD=0
47949       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
47950         NPA=1
47951         IPA(1)=IP1
47952       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
47953      &  MSTU(32))) THEN
47954         NPA=2
47955         IPA(1)=IP1
47956         IPA(2)=IP2
47957       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
47958      &  .AND.IP2.GE.-7) THEN
47959         NPA=IABS(IP2)
47960         DO 130 I=1,NPA
47961           IPA(I)=IP1+I-1
47962   130   CONTINUE
47963       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
47964      &IP2.EQ.-8) THEN
47965         MPSPD=1
47966         NPA=2
47967         IPA(1)=IP1+6
47968         IPA(2)=IP1+7
47969       ELSE
47970         CALL PYERRM(12,
47971      &  '(PYSHOW:) failed to reconstruct showering system')
47972         IF(MSTU(21).GE.1) RETURN
47973       ENDIF
47974
47975 C...Check on phase space available for emission.
47976       IREJ=0
47977       DO 140 J=1,5
47978         PS(J)=0D0
47979   140 CONTINUE
47980       PM=0D0
47981       DO 160 I=1,NPA
47982         KFLA(I)=IABS(K(IPA(I),2))
47983         PMA(I)=P(IPA(I),5)
47984 C...Special cutoff masses for initial partons (may be a heavy quark,
47985 C...squark, ..., and need not be on the mass shell).
47986         IR=30+I
47987         IF(NPA.LE.1) IREF(I)=IR
47988         IF(NPA.GE.2) IREF(I+1)=IR
47989         IF(KFLA(I).LE.8) THEN
47990           ISCOL(IR)=1
47991           IF(MSTJ(41).GE.2) ISCHG(IR)=1
47992         ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
47993      &  KFLA(I).EQ.17) THEN
47994           IF(MSTJ(41).GE.2) ISCHG(IR)=1
47995         ELSEIF(KFLA(I).EQ.21) THEN
47996           ISCOL(IR)=1
47997         ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
47998      &  (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
47999           ISCOL(IR)=1
48000         ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
48001           ISCOL(IR)=1
48002         ENDIF
48003         IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
48004         PMTH(1,IR)=PMA(I)
48005         IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
48006           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
48007           PMTH(3,IR)=PMTH(2,IR)+PMQTH2
48008           PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
48009           PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
48010         ELSEIF(ISCOL(IR).EQ.1) THEN
48011           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
48012           PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
48013           PMTH(4,IR)=PMTH(3,IR)
48014           PMTH(5,IR)=PMTH(3,IR)
48015         ELSEIF(ISCHG(IR).EQ.1) THEN
48016           PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
48017           PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
48018           PMTH(4,IR)=PMTH(3,IR)
48019           PMTH(5,IR)=PMTH(3,IR)
48020         ENDIF
48021         IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
48022         PM=PM+PMA(I)
48023         IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
48024         DO 150 J=1,4
48025           PS(J)=PS(J)+P(IPA(I),J)
48026   150   CONTINUE
48027   160 CONTINUE
48028       IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
48029       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
48030       IF(NPA.EQ.1) PS(5)=PS(4)
48031       IF(PS(5).LE.PM+PMQT1E) RETURN
48032
48033 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
48034       KFSRCE=0
48035       IF(IP2.LE.0) THEN
48036       ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
48037         KFSRCE=IABS(K(K(IP1,3),2))
48038       ELSE
48039         IPAR1=MAX(1,K(IP1,3))
48040         IPAR2=MAX(1,K(IP2,3))
48041         IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
48042      &       KFSRCE=IABS(K(K(IPAR1,3),2))
48043       ENDIF
48044       ITYPES=0
48045       IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
48046       IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
48047       IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
48048       IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
48049       IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
48050       IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
48051       IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
48052       IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
48053
48054 C...Identify two primary showerers.
48055       ITYPE1=0
48056       IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
48057       IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
48058       IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
48059       IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
48060       IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
48061       IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
48062       IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
48063       IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
48064       ITYPE2=0
48065       IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
48066       IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
48067       IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
48068       IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
48069       IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
48070       IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
48071       IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
48072       IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
48073
48074 C...Order of showerers. Presence of gluino.
48075       ITYPMN=MIN(ITYPE1,ITYPE2)
48076       ITYPMX=MAX(ITYPE1,ITYPE2)
48077       IORD=1
48078       IF(ITYPE1.GT.ITYPE2) IORD=2
48079       IGLUI=0
48080       IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
48081
48082 C...Check if 3-jet matrix elements to be used.
48083       M3JC=0
48084       ALPHA=0.5D0
48085       IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
48086         IF(MSTJ(38).NE.0) THEN
48087           M3JC=MSTJ(38)
48088           ALPHA=PARJ(80)
48089           MSTJ(38)=0
48090         ELSEIF(MSTJ(47).GE.6) THEN
48091           M3JC=MSTJ(47)
48092         ELSE
48093           ICLASS=1
48094           ICOMBI=4
48095
48096 C...Vector/axial vector -> q + qbar; q -> q + V.
48097           IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
48098      &    ITYPES.EQ.3)) THEN
48099             ICLASS=2
48100             IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
48101               ICOMBI=1
48102             ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
48103      &      K(IP1,2)+K(IP2,2).EQ.0)) THEN
48104 C...gamma*/Z0: assume e+e- initial state if unknown.
48105               EI=-1D0
48106               IF(KFSRCE.EQ.23) THEN
48107                 IANNFL=K(K(IP1,3),3)
48108                 IF(IANNFL.NE.0) THEN
48109                   KANNFL=IABS(K(IANNFL,2))
48110                   IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
48111                 ENDIF
48112               ENDIF
48113               AI=SIGN(1D0,EI+0.1D0)
48114               VI=AI-4D0*EI*PARU(102)
48115               EF=KCHG(KFLA(1),1)/3D0
48116               AF=SIGN(1D0,EF+0.1D0)
48117               VF=AF-4D0*EF*PARU(102)
48118               XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
48119               SH=PS(5)**2
48120               SQMZ=PMAS(23,1)**2
48121               SQWZ=PS(5)*PMAS(23,2)
48122               SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
48123               VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
48124      &        (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
48125               AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
48126               ICOMBI=3
48127               ALPHA=VECT/(VECT+AXIV)
48128             ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
48129               ICOMBI=4
48130             ENDIF
48131 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
48132           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
48133             ICLASS=2
48134           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48135      &    ITYPES.EQ.1)) THEN
48136             ICLASS=3
48137
48138 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
48139           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
48140             ICLASS=4
48141             IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
48142               ICOMBI=1
48143             ELSEIF(KFSRCE.EQ.36) THEN
48144               ICOMBI=2
48145             ENDIF
48146           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48147      &    ITYPES.EQ.1)) THEN
48148             ICLASS=5
48149
48150 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
48151           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48152      &    ITYPES.EQ.3)) THEN
48153             ICLASS=6
48154           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48155      &    ITYPES.EQ.2)) THEN
48156             ICLASS=7
48157           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
48158             ICLASS=8
48159           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48160      &    ITYPES.EQ.2)) THEN
48161             ICLASS=9
48162
48163 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
48164           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48165      &    ITYPES.EQ.5)) THEN
48166             ICLASS=10
48167           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48168      &    ITYPES.EQ.2)) THEN
48169             ICLASS=11
48170           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48171      &    ITYPES.EQ.1)) THEN
48172             ICLASS=12
48173
48174 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
48175           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
48176             ICLASS=13
48177           ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48178      &    ITYPES.EQ.2)) THEN
48179             ICLASS=14
48180           ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48181      &    ITYPES.EQ.1)) THEN
48182             ICLASS=15
48183
48184 C...g -> ~g + ~g (eikonal approximation).
48185           ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
48186             ICLASS=16
48187           ENDIF
48188           M3JC=5*ICLASS+ICOMBI
48189         ENDIF
48190       ENDIF
48191
48192 C...Find if interference with initial state partons.
48193       MIIS=0
48194       IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
48195      &MIIS=MSTJ(50)
48196       IF(MIIS.NE.0) THEN
48197         DO 180 I=1,2
48198           KCII(I)=0
48199           KCA=PYCOMP(KFLA(I))
48200           IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
48201           NIIS(I)=0
48202           IF(KCII(I).NE.0) THEN
48203             DO 170 J=1,2
48204               ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
48205               IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
48206      &        (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
48207                 NIIS(I)=NIIS(I)+1
48208                 IIIS(I,NIIS(I))=ICSI
48209               ENDIF
48210   170       CONTINUE
48211           ENDIF
48212   180   CONTINUE
48213         IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
48214       ENDIF
48215
48216 C...Boost interfering initial partons to rest frame
48217 C...and reconstruct their polar and azimuthal angles.
48218       IF(MIIS.NE.0) THEN
48219         DO 200 I=1,2
48220           DO 190 J=1,5
48221             K(N+I,J)=K(IPA(I),J)
48222             P(N+I,J)=P(IPA(I),J)
48223             V(N+I,J)=0D0
48224   190     CONTINUE
48225   200   CONTINUE
48226         DO 220 I=3,2+NIIS(1)
48227           DO 210 J=1,5
48228             K(N+I,J)=K(IIIS(1,I-2),J)
48229             P(N+I,J)=P(IIIS(1,I-2),J)
48230             V(N+I,J)=0D0
48231   210     CONTINUE
48232   220   CONTINUE
48233         DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48234           DO 230 J=1,5
48235             K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
48236             P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
48237             V(N+I,J)=0D0
48238   230     CONTINUE
48239   240   CONTINUE
48240         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
48241      &  -PS(2)/PS(4),-PS(3)/PS(4))
48242         PHI=PYANGL(P(N+1,1),P(N+1,2))
48243         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
48244         THE=PYANGL(P(N+1,3),P(N+1,1))
48245         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
48246         DO 250 I=3,2+NIIS(1)
48247           THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
48248           PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
48249   250   CONTINUE
48250         DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48251           THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
48252      &    SQRT(P(N+I,1)**2+P(N+I,2)**2))
48253           PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
48254   260   CONTINUE
48255       ENDIF
48256
48257 C...Boost 3 or more partons to their rest frame.
48258       IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
48259      &-PS(2)/PS(4),-PS(3)/PS(4))
48260
48261 C...Define imagined single initiator of shower for parton system.
48262       NS=N
48263       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
48264         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48265         IF(MSTU(21).GE.1) RETURN
48266       ENDIF
48267   270 N=NS
48268       IF(NPA.GE.2) THEN
48269         K(N+1,1)=11
48270         K(N+1,2)=21
48271         K(N+1,3)=0
48272         K(N+1,4)=0
48273         K(N+1,5)=0
48274         P(N+1,1)=0D0
48275         P(N+1,2)=0D0
48276         P(N+1,3)=0D0
48277         P(N+1,4)=PS(5)
48278         P(N+1,5)=PS(5)
48279         V(N+1,5)=PS(5)**2
48280         N=N+1
48281         IREF(1)=21
48282       ENDIF
48283
48284 C...Loop over partons that may branch.
48285       NEP=NPA
48286       IM=NS
48287       IF(NPA.EQ.1) IM=NS-1
48288   280 IM=IM+1
48289       IF(N.GT.NS) THEN
48290         IF(IM.GT.N) GOTO 590
48291         KFLM=IABS(K(IM,2))
48292         IR=IREF(IM-NS)
48293         IF(KSH(IR).EQ.0) GOTO 280
48294         IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
48295         IGM=K(IM,3)
48296       ELSE
48297         IGM=-1
48298       ENDIF
48299       IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
48300         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48301         IF(MSTU(21).GE.1) RETURN
48302       ENDIF
48303
48304 C...Position of aunt (sister to branching parton).
48305 C...Origin and flavour of daughters.
48306       IAU=0
48307       IF(IGM.GT.0) THEN
48308         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
48309         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
48310       ENDIF
48311       IF(IGM.GE.0) THEN
48312         K(IM,4)=N+1
48313         DO 290 I=1,NEP
48314           K(N+I,3)=IM
48315   290   CONTINUE
48316       ELSE
48317         K(N+1,3)=IPA(1)
48318       ENDIF
48319       IF(IGM.LE.0) THEN
48320         DO 300 I=1,NEP
48321           K(N+I,2)=K(IPA(I),2)
48322   300   CONTINUE
48323       ELSEIF(KFLM.NE.21) THEN
48324         K(N+1,2)=K(IM,2)
48325         K(N+2,2)=K(IM,5)
48326         IREF(N+1-NS)=IREF(IM-NS)
48327         IREF(N+2-NS)=IABS(K(N+2,2))
48328       ELSEIF(K(IM,5).EQ.21) THEN
48329         K(N+1,2)=21
48330         K(N+2,2)=21
48331         IREF(N+1-NS)=21
48332         IREF(N+2-NS)=21
48333       ELSE
48334         K(N+1,2)=K(IM,5)
48335         K(N+2,2)=-K(IM,5)
48336         IREF(N+1-NS)=IABS(K(N+1,2))
48337         IREF(N+2-NS)=IABS(K(N+2,2))
48338       ENDIF
48339
48340 C...Reset flags on daughters and tries made.
48341       DO 310 IP=1,NEP
48342         K(N+IP,1)=3
48343         K(N+IP,4)=0
48344         K(N+IP,5)=0
48345         KFLD(IP)=IABS(K(N+IP,2))
48346         IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
48347         ITRY(IP)=0
48348         ISL(IP)=0
48349         ISI(IP)=0
48350         IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
48351   310 CONTINUE
48352       ISLM=0
48353
48354 C...Maximum virtuality of daughters.
48355       IF(IGM.LE.0) THEN
48356         DO 320 I=1,NPA
48357           IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
48358           P(N+I,5)=MIN(QMAX,PS(5))
48359           IR=IREF(N+I-NS)
48360           IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
48361           IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
48362   320   CONTINUE
48363       ELSE
48364         IF(MSTJ(43).LE.2) PEM=V(IM,2)
48365         IF(MSTJ(43).GE.3) PEM=P(IM,4)
48366         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
48367         P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
48368         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
48369       ENDIF
48370       DO 330 I=1,NEP
48371         PMSD(I)=P(N+I,5)
48372         IF(ISI(I).EQ.1) THEN
48373           IR=IREF(N+I-NS)
48374           IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
48375         ENDIF
48376         V(N+I,5)=P(N+I,5)**2
48377   330 CONTINUE
48378
48379 C...Choose one of the daughters for evolution.
48380   340 INUM=0
48381       IF(NEP.EQ.1) INUM=1
48382       DO 350 I=1,NEP
48383         IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
48384   350 CONTINUE
48385       DO 360 I=1,NEP
48386         IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
48387           IR=IREF(N+I-NS)
48388           IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
48389         ENDIF
48390   360 CONTINUE
48391       IF(INUM.EQ.0) THEN
48392         RMAX=0D0
48393         DO 370 I=1,NEP
48394           IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
48395             RPM=P(N+I,5)/PMSD(I)
48396             IR=IREF(N+I-NS)
48397             IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
48398               RMAX=RPM
48399               INUM=I
48400             ENDIF
48401           ENDIF
48402   370   CONTINUE
48403       ENDIF
48404
48405 C...Cancel choice of predetermined daughter already treated.
48406       INUM=MAX(1,INUM)
48407       INUMT=INUM
48408       IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
48409         IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
48410       ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
48411         IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
48412         IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
48413       ENDIF
48414
48415 C...Store information on choice of evolving daughter.
48416       IEP(1)=N+INUM
48417       DO 380 I=2,NEP
48418         IEP(I)=IEP(I-1)+1
48419         IF(IEP(I).GT.N+NEP) IEP(I)=N+1
48420   380 CONTINUE
48421       DO 390 I=1,NEP
48422         KFL(I)=IABS(K(IEP(I),2))
48423   390 CONTINUE
48424       ITRY(INUM)=ITRY(INUM)+1
48425       IF(ITRY(INUM).GT.200) THEN
48426         CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
48427         IF(MSTU(21).GE.1) RETURN
48428       ENDIF
48429       Z=0.5D0
48430       IR=IREF(IEP(1)-NS)
48431       IF(KSH(IR).EQ.0) GOTO 440
48432       IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
48433
48434 C...Check if evolution already predetermined for daughter.
48435       IPSPD=0
48436       IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
48437         IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
48438       ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
48439         IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
48440         IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
48441       ENDIF
48442       ISSET(INUM)=0
48443       IF(IPSPD.NE.0) ISSET(INUM)=1
48444
48445 C...Select side for interference with initial state partons.
48446       IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
48447         III=IEP(1)-NS-1
48448         ISII(III)=0
48449         IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
48450           ISII(III)=1
48451         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
48452           IF(PYR(0).GT.0.5D0) ISII(III)=1
48453         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
48454           ISII(III)=1
48455           IF(PYR(0).GT.0.5D0) ISII(III)=2
48456         ENDIF
48457       ENDIF
48458
48459 C...Calculate allowed z range.
48460       IF(NEP.EQ.1) THEN
48461         PMED=PS(4)
48462       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48463         PMED=P(IM,5)
48464       ELSE
48465         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
48466         IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
48467       ENDIF
48468       IF(MOD(MSTJ(43),2).EQ.1) THEN
48469         ZC=PMTH(2,21)/PMED
48470         ZCE=PMTH(2,22)/PMED
48471         IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
48472       ELSE
48473         ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
48474         IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
48475         PMTMPE=PMTH(2,22)
48476         IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
48477         ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
48478         IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
48479       ENDIF
48480       ZC=MIN(ZC,0.491D0)
48481       ZCE=MIN(ZCE,0.49991D0)
48482       IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
48483      &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
48484         P(IEP(1),5)=PMTH(1,IR)
48485         V(IEP(1),5)=P(IEP(1),5)**2
48486         GOTO 440
48487       ENDIF
48488
48489 C...Integral of Altarelli-Parisi z kernel for QCD.
48490 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
48491       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
48492         FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
48493       ELSEIF(MSTJ(49).EQ.0) THEN
48494         FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
48495         IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
48496
48497 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
48498       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
48499         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
48500       ELSEIF(MSTJ(49).EQ.1) THEN
48501         FBR=(1D0-2D0*ZC)/3D0
48502         IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
48503
48504 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
48505       ELSEIF(KFL(1).EQ.21) THEN
48506         FBR=6D0*MSTJ(45)*(0.5D0-ZC)
48507       ELSE
48508         FBR=2D0*LOG((1D0-ZC)/ZC)
48509       ENDIF
48510
48511 C...Reset QCD probability for colourless.
48512       IF(ISCOL(IR).EQ.0) FBR=0D0
48513
48514 C...Integral of Altarelli-Parisi kernel for photon emission.
48515       FBRE=0D0
48516       IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
48517         IF(KFL(1).LE.18) THEN
48518           FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
48519         ENDIF
48520         IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
48521       ENDIF
48522
48523 C...Inner veto algorithm starts. Find maximum mass for evolution.
48524   400 PMS=V(IEP(1),5)
48525       IF(IGM.GE.0) THEN
48526         PM2=0D0
48527         DO 410 I=2,NEP
48528           PM=P(IEP(I),5)
48529           IRI=IREF(IEP(I)-NS)
48530           IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
48531           PM2=PM2+PM
48532   410   CONTINUE
48533         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
48534       ENDIF
48535
48536 C...Select mass for daughter in QCD evolution.
48537       B0=27D0/6D0
48538       DO 420 IFF=4,MSTJ(45)
48539         IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
48540   420 CONTINUE
48541 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48542       PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
48543 C...Already predetermined choice.
48544       IF(IPSPD.NE.0) THEN
48545         PMSQCD=P(IPSPD,5)**2
48546       ELSEIF(FBR.LT.1D-3) THEN
48547         PMSQCD=0D0
48548       ELSEIF(MSTJ(44).LE.0) THEN
48549         PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
48550       ELSEIF(MSTJ(44).EQ.1) THEN
48551         PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
48552       ELSE
48553         PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
48554       ENDIF
48555 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48556       IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
48557       IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
48558       V(IEP(1),5)=PMSQCD
48559       MCE=1
48560
48561 C...Select mass for daughter in QED evolution.
48562       IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
48563 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48564         PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
48565         IF(FBRE.LT.1D-3) THEN
48566           PMSQED=0D0
48567         ELSE
48568           PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
48569      &    (PARU(101)*FBRE)))
48570         ENDIF
48571 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48572         PMSQED=PMSQED+PMTH(1,IR)**2
48573         IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
48574      &  PMTH(2,IR)**2
48575         IF(PMSQED.GT.PMSQCD) THEN
48576           V(IEP(1),5)=PMSQED
48577           MCE=2
48578         ENDIF
48579       ENDIF
48580
48581 C...Check whether daughter mass below cutoff.
48582       P(IEP(1),5)=SQRT(V(IEP(1),5))
48583       IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
48584         P(IEP(1),5)=PMTH(1,IR)
48585         V(IEP(1),5)=P(IEP(1),5)**2
48586         GOTO 440
48587       ENDIF
48588
48589 C...Already predetermined choice of z, and flavour in g -> qqbar.
48590       IF(IPSPD.NE.0) THEN
48591         IPSGD1=K(IPSPD,4)
48592         IPSGD2=K(IPSPD,5)
48593         PMSGD1=P(IPSGD1,5)**2
48594         PMSGD2=P(IPSGD2,5)**2
48595         ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
48596      &  4D0*PMSGD1*PMSGD2))
48597         Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
48598      &  PMSGD1+PMSGD2)/ALAMPS
48599         Z=MAX(0.00001D0,MIN(0.99999D0,Z))
48600         IF(KFL(1).NE.21) THEN
48601           K(IEP(1),5)=21
48602         ELSE
48603           K(IEP(1),5)=IABS(K(IPSGD1,2))
48604         ENDIF
48605
48606 C...Select z value of branching: q -> qgamma.
48607       ELSEIF(MCE.EQ.2) THEN
48608         Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
48609         IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48610         K(IEP(1),5)=22
48611
48612 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
48613       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
48614         Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48615 C...Only do z weighting when no ME correction afterwards.
48616         IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48617         K(IEP(1),5)=21
48618       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
48619         Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48620         IF(PYR(0).GT.0.5D0) Z=1D0-Z
48621         IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
48622         K(IEP(1),5)=21
48623       ELSEIF(MSTJ(49).NE.1) THEN
48624         Z=PYR(0)
48625         IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
48626         KFLB=1+INT(MSTJ(45)*PYR(0))
48627         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48628         IF(PMQ.GE.1D0) GOTO 400
48629         IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
48630           IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
48631           PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
48632           IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
48633      &    .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
48634         ELSE
48635           IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
48636         ENDIF
48637         K(IEP(1),5)=KFLB
48638
48639 C...Ditto for scalar gluon model.
48640       ELSEIF(KFL(1).NE.21) THEN
48641         Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
48642         K(IEP(1),5)=21
48643       ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
48644         Z=ZC+(1D0-2D0*ZC)*PYR(0)
48645         K(IEP(1),5)=21
48646       ELSE
48647         Z=ZC+(1D0-2D0*ZC)*PYR(0)
48648         KFLB=1+INT(MSTJ(45)*PYR(0))
48649         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48650         IF(PMQ.GE.1D0) GOTO 400
48651         K(IEP(1),5)=KFLB
48652       ENDIF
48653
48654 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
48655       IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
48656         IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48657      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48658           IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
48659         ELSE
48660           PT2APP=Z*(1D0-Z)*V(IEP(1),5)
48661           IF(MSTJ(44).GE.4) PT2APP=PT2APP*
48662      &    (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
48663           IF(PT2APP.LT.PT2MIN) GOTO 400
48664           IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
48665         ENDIF
48666       ENDIF
48667
48668 C...Check if z consistent with chosen m.
48669       IF(KFL(1).EQ.21) THEN
48670         IRGD1=IABS(K(IEP(1),5))
48671         IRGD2=IRGD1
48672       ELSE
48673         IRGD1=IR
48674         IRGD2=IABS(K(IEP(1),5))
48675       ENDIF
48676       IF(NEP.EQ.1) THEN
48677         PED=PS(4)
48678       ELSEIF(NEP.GE.3) THEN
48679         PED=P(IEP(1),4)
48680       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48681         PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
48682       ELSE
48683         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
48684         IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
48685       ENDIF
48686       IF(MOD(MSTJ(43),2).EQ.1) THEN
48687         PMQTH3=0.5D0*PARJ(82)
48688         IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48689         IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
48690         PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
48691         PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
48692         ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48693      &  4D0*PMQ1*PMQ2)))
48694         ZH=1D0+PMQ1-PMQ2
48695       ELSE
48696         ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
48697         ZH=1D0
48698       ENDIF
48699       IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48700      &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48701       ELSEIF(IPSPD.NE.0) THEN
48702       ELSE
48703         ZL=0.5D0*(ZH-ZD)
48704         ZU=0.5D0*(ZH+ZD)
48705         IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
48706       ENDIF
48707       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
48708      &(1D0-ZU)))
48709       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48710
48711 C...Width suppression for q -> q + g.
48712       IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
48713         IF(IGM.EQ.0) THEN
48714           EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
48715         ELSE
48716           EGLU=PMED*(1D0-Z)
48717         ENDIF
48718         CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
48719         IF(MSTJ(40).EQ.1) THEN
48720           IF(CHI.LT.PYR(0)) GOTO 400
48721         ELSEIF(MSTJ(40).EQ.2) THEN
48722           IF(1D0-CHI.LT.PYR(0)) GOTO 400
48723         ENDIF
48724       ENDIF
48725
48726 C...Three-jet matrix element correction.
48727       IF(M3JC.GE.1) THEN
48728         WME=1D0
48729         WSHOW=1D0
48730
48731 C...QED matrix elements: only for massless case so far.
48732         IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
48733           X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48734           X2=1D0-V(IEP(1),5)/V(NS+1,5)
48735           X3=(1D0-X1)+(1D0-X2)
48736           KI1=K(IPA(INUM),2)
48737           KI2=K(IPA(3-INUM),2)
48738           QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
48739           QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
48740           WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
48741      &    QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
48742           WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
48743         ELSEIF(MCE.EQ.2) THEN
48744
48745 C...QCD matrix elements, including mass effects.
48746         ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
48747           PS1ME=V(IEP(1),5)
48748           PM1ME=PMTH(1,IR)
48749           M3JCC=M3JC
48750           IF(IR.GE.31.AND.IGM.EQ.0) THEN
48751 C...QCD ME: original parton, first branching.
48752             PM2ME=PMTH(1,63-IR)
48753             ECMME=PS(5)
48754           ELSEIF(IR.GE.31) THEN
48755 C...QCD ME: original parton, subsequent branchings.
48756             PM2ME=PMTH(1,63-IR)
48757             PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48758             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48759           ELSEIF(K(IM,2).EQ.21) THEN
48760 C...QCD ME: secondary partons, first branching.
48761             PM2ME=PM1ME
48762             ZMME=V(IM,1)
48763             IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
48764             PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
48765      &      4D0*PS1ME*PM2ME**2))
48766             PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
48767      &      V(IM,5)
48768             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48769             M3JCC=66
48770           ELSE
48771 C...QCD ME: secondary partons, subsequent branchings.
48772             PM2ME=PM1ME
48773             PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48774             ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48775             M3JCC=66
48776           ENDIF
48777 C...Construct ME variables.
48778           R1ME=PM1ME/ECMME
48779           R2ME=PM2ME/ECMME
48780           X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
48781           X2=1D0+R2ME**2-PS1ME/ECMME**2
48782 C...Call ME, with right order important for two inequivalent showerers.
48783           IF(IR.EQ.IORD+30) THEN
48784             WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
48785           ELSE
48786             WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
48787           ENDIF
48788 C...Split up total ME when two radiating partons.
48789           ISPRAD=1
48790           IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
48791      &    (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
48792      &    (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
48793      &    (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
48794      &    (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
48795           IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
48796      &    MAX(1D-10,2D0-X1-X2)
48797 C...Evaluate shower rate to be compared with.
48798           WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
48799      &    MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
48800           IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
48801         ELSEIF(MSTJ(49).NE.1) THEN
48802
48803 C...Toy model scalar theory matrix elements; no mass effects.
48804         ELSE
48805           X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48806           X2=1D0-V(IEP(1),5)/V(NS+1,5)
48807           X3=(1D0-X1)+(1D0-X2)
48808           WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
48809           WME=X3**2
48810           IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
48811      &    PARJ(171)
48812         ENDIF
48813
48814         IF(WME.LT.PYR(0)*WSHOW) GOTO 400
48815       ENDIF
48816
48817 C...Impose angular ordering by rejection of nonordered emission.
48818       IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
48819         PEMAO=V(IM,1)*P(IM,4)
48820         IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
48821         IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
48822           MAOD=0
48823         ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
48824      &  .OR.MSTJ(42).EQ.7)) THEN
48825           MAOD=0
48826         ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
48827      &  .OR.MSTJ(42).EQ.6)) THEN
48828           MAOD=1
48829           PMDAO=PMTH(2,K(IEP(1),5))
48830           THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
48831         ELSE
48832           MAOD=1
48833           THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
48834           IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
48835      &    (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
48836         ENDIF
48837         MAOM=1
48838         IAOM=IM
48839   430   IF(K(IAOM,5).EQ.22) THEN
48840           IAOM=K(IAOM,3)
48841           IF(K(IAOM,3).LE.NS) MAOM=0
48842           IF(MAOM.EQ.1) GOTO 430
48843         ENDIF
48844         IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
48845           THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
48846           IF(THE2ID.LT.THE2IM) GOTO 400
48847         ENDIF
48848       ENDIF
48849
48850 C...Impose user-defined maximum angle at first branching.
48851       IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
48852         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
48853           THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
48854           IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48855         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
48856           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48857           IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48858         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
48859           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48860           IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
48861         ENDIF
48862       ENDIF
48863
48864 C...Impose angular constraint in first branching from interference
48865 C...with initial state partons.
48866       IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
48867         THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
48868         IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
48869           IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
48870         ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
48871           IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
48872         ENDIF
48873       ENDIF
48874
48875 C...End of inner veto algorithm. Check if only one leg evolved so far.
48876   440 V(IEP(1),1)=Z
48877       ISL(1)=0
48878       ISL(2)=0
48879       IF(NEP.EQ.1) GOTO 480
48880       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
48881       DO 450 I=1,NEP
48882         IR=IREF(N+I-NS)
48883         IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
48884           IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
48885         ENDIF
48886   450 CONTINUE
48887
48888 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
48889       IF(NEP.GE.3) THEN
48890         PMSUM=0D0
48891         DO 460 I=1,NEP
48892           PMSUM=PMSUM+P(N+I,5)
48893   460   CONTINUE
48894         IF(PMSUM.GE.PS(5)) GOTO 340
48895       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
48896         DO 470 I1=N+1,N+2
48897           IRDA=IREF(I1-NS)
48898           IF(KSH(IRDA).EQ.0) GOTO 470
48899           IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
48900           IF(IRDA.EQ.21) THEN
48901             IRGD1=IABS(K(I1,5))
48902             IRGD2=IRGD1
48903           ELSE
48904             IRGD1=IRDA
48905             IRGD2=IABS(K(I1,5))
48906           ENDIF
48907           I2=2*N+3-I1
48908           IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48909             PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
48910           ELSE
48911             IF(I1.EQ.N+1) ZM=V(IM,1)
48912             IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
48913             PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
48914      &      4D0*V(N+1,5)*V(N+2,5))
48915             PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
48916      &      V(IM,5)
48917           ENDIF
48918           IF(MOD(MSTJ(43),2).EQ.1) THEN
48919             PMQTH3=0.5D0*PARJ(82)
48920             IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48921             IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
48922             PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
48923             PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
48924             ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48925      &      4D0*PMQ1*PMQ2)))
48926             ZH=1D0+PMQ1-PMQ2
48927           ELSE
48928             ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
48929             ZH=1D0
48930           ENDIF
48931           IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
48932      &    (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48933           ELSE
48934             ZL=0.5D0*(ZH-ZD)
48935             ZU=0.5D0*(ZH+ZD)
48936             IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48937      &      ISSET(1).EQ.0) THEN
48938               ISL(1)=1
48939             ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48940      &      ISSET(2).EQ.0) THEN
48941               ISL(2)=1
48942             ENDIF
48943           ENDIF
48944           IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
48945      &    ZL*(1D0-ZU)))
48946           IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48947   470   CONTINUE
48948         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
48949           ISL(3-ISLM)=0
48950           ISLM=3-ISLM
48951         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
48952           ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
48953           ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
48954           IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
48955           IF(ISL(1).EQ.1) ISL(2)=0
48956           IF(ISL(1).EQ.0) ISLM=1
48957           IF(ISL(2).EQ.0) ISLM=2
48958         ENDIF
48959         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
48960       ENDIF
48961       IRD1=IREF(N+1-NS)
48962       IRD2=IREF(N+2-NS)
48963       IF(IGM.GT.0) THEN
48964         IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
48965      &  PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
48966           PMQ1=V(N+1,5)/V(IM,5)
48967           PMQ2=V(N+2,5)/V(IM,5)
48968           ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
48969      &    4D0*PMQ1*PMQ2)))
48970           ZH=1D0+PMQ1-PMQ2
48971           ZL=0.5D0*(ZH-ZD)
48972           ZU=0.5D0*(ZH+ZD)
48973           IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
48974         ENDIF
48975       ENDIF
48976
48977 C...Accepted branch. Construct four-momentum for initial partons.
48978   480 MAZIP=0
48979       MAZIC=0
48980       IF(NEP.EQ.1) THEN
48981         P(N+1,1)=0D0
48982         P(N+1,2)=0D0
48983         P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
48984      &  P(N+1,5))))
48985         P(N+1,4)=P(IPA(1),4)
48986         V(N+1,2)=P(N+1,4)
48987       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
48988         PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
48989         P(N+1,1)=0D0
48990         P(N+1,2)=0D0
48991         P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
48992         P(N+1,4)=PED1
48993         P(N+2,1)=0D0
48994         P(N+2,2)=0D0
48995         P(N+2,3)=-P(N+1,3)
48996         P(N+2,4)=P(IM,5)-PED1
48997         V(N+1,2)=P(N+1,4)
48998         V(N+2,2)=P(N+2,4)
48999       ELSEIF(NEP.GE.3) THEN
49000 C...Rescale all momenta for energy conservation.
49001         LOOP=0
49002         PES=0D0
49003         PQS=0D0
49004         DO 500 I=1,NEP
49005           DO 490 J=1,4
49006             P(N+I,J)=P(IPA(I),J)
49007   490     CONTINUE
49008           PES=PES+P(N+I,4)
49009           PQS=PQS+P(N+I,5)**2/P(N+I,4)
49010   500   CONTINUE
49011   510   LOOP=LOOP+1
49012         FAC=(PS(5)-PQS)/(PES-PQS)
49013         PES=0D0
49014         PQS=0D0
49015         DO 530 I=1,NEP
49016           DO 520 J=1,3
49017             P(N+I,J)=FAC*P(N+I,J)
49018   520     CONTINUE
49019           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)
49020           V(N+I,2)=P(N+I,4)
49021           PES=PES+P(N+I,4)
49022           PQS=PQS+P(N+I,5)**2/P(N+I,4)
49023   530   CONTINUE
49024         IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
49025
49026 C...Construct transverse momentum for ordinary branching in shower.
49027       ELSE
49028         ZM=V(IM,1)
49029         LOOPPT=0
49030   540   LOOPPT=LOOPPT+1
49031         PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
49032         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
49033         IF(PZM.LE.0D0) THEN
49034           PTS=0D0
49035         ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49036      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49037           PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
49038         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49039           PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
49040      &    ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
49041         ELSE
49042           PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
49043         ENDIF
49044         IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
49045           ZM=0.05D0+0.9D0*ZM
49046           GOTO 540
49047         ELSEIF(PTS.LT.0D0) THEN
49048           GOTO 270
49049         ENDIF
49050         PT=SQRT(MAX(0D0,PTS))
49051
49052 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
49053         HAZIP=0D0
49054         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
49055      &  .AND.IAU.NE.0) THEN
49056           IF(K(IGM,3).NE.0) MAZIP=1
49057           ZAU=V(IGM,1)
49058           IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
49059           IF(MAZIP.EQ.0) ZAU=0D0
49060           IF(K(IGM,2).NE.21) THEN
49061             HAZIP=2D0*ZAU/(1D0+ZAU**2)
49062           ELSE
49063             HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
49064           ENDIF
49065           IF(K(N+1,2).NE.21) THEN
49066             HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
49067           ELSE
49068             HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
49069           ENDIF
49070         ENDIF
49071
49072 C...Find coefficient of azimuthal asymmetry due to soft gluon
49073 C...interference.
49074         HAZIC=0D0
49075         IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
49076      &  K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
49077           IF(K(IGM,3).NE.0) MAZIC=N+1
49078           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
49079           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49080      &    ZM.GT.0.5D0) MAZIC=N+2
49081           IF(K(IAU,2).EQ.22) MAZIC=0
49082           ZS=ZM
49083           IF(MAZIC.EQ.N+2) ZS=1D0-ZM
49084           ZGM=V(IGM,1)
49085           IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
49086           IF(MAZIC.EQ.0) ZGM=1D0
49087           IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
49088      &    SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
49089           HAZIC=MIN(0.95D0,HAZIC)
49090         ENDIF
49091       ENDIF
49092
49093 C...Construct energies for ordinary branching in shower.
49094   550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
49095         IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49096      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49097           P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49098      &    PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49099         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49100           P(N+1,4)=PEM*V(IM,1)
49101         ELSE
49102           P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
49103      &    SQRT(PMLS)*ZM)/V(IM,5)
49104         ENDIF
49105
49106 C...Already predetermined choice of phi angle or not
49107         PHI=PARU(2)*PYR(0)
49108         IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
49109           IPSPD=IP1+IM-NS-2
49110           IF(K(IPSPD,4).GT.0) THEN
49111             IPSGD1=K(IPSPD,4)
49112             IF(IM.EQ.NS+2) THEN
49113               PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49114             ELSE
49115               PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
49116             ENDIF
49117           ENDIF
49118         ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
49119           IPSPD=IP1+IM-NS-2
49120           IF(K(IPSPD,4).GT.0) THEN
49121             IPSGD1=K(IPSPD,4)
49122             PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
49123             THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
49124             CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
49125             CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
49126             PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49127             CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
49128           ENDIF
49129         ENDIF
49130
49131 C...Construct momenta for ordinary branching in shower.
49132         P(N+1,1)=PT*COS(PHI)
49133         P(N+1,2)=PT*SIN(PHI)
49134         IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49135      &  (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49136           P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49137      &    PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49138         ELSEIF(PZM.GT.0D0) THEN
49139           P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
49140      &    2D0*PEM*P(N+1,4))/PZM
49141         ELSE
49142           P(N+1,3)=0D0
49143         ENDIF
49144         P(N+2,1)=-P(N+1,1)
49145         P(N+2,2)=-P(N+1,2)
49146         P(N+2,3)=PZM-P(N+1,3)
49147         P(N+2,4)=PEM-P(N+1,4)
49148         IF(MSTJ(43).LE.2) THEN
49149           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
49150           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
49151         ENDIF
49152       ENDIF
49153
49154 C...Rotate and boost daughters.
49155       IF(IGM.GT.0) THEN
49156         IF(MSTJ(43).LE.2) THEN
49157           BEX=P(IGM,1)/P(IGM,4)
49158           BEY=P(IGM,2)/P(IGM,4)
49159           BEZ=P(IGM,3)/P(IGM,4)
49160           GA=P(IGM,4)/P(IGM,5)
49161           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
49162      &    P(IM,4))
49163         ELSE
49164           BEX=0D0
49165           BEY=0D0
49166           BEZ=0D0
49167           GA=1D0
49168           GABEP=0D0
49169         ENDIF
49170         PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
49171         THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
49172         IF(PTIMB.GT.1D-4) THEN
49173           PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
49174         ELSE
49175           PHI=0D0
49176         ENDIF
49177         DO 560 I=N+1,N+2
49178           DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
49179      &    SIN(THE)*COS(PHI)*P(I,3)
49180           DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
49181      &    SIN(THE)*SIN(PHI)*P(I,3)
49182           DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
49183           DP(4)=P(I,4)
49184           DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
49185           DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
49186           P(I,1)=DP(1)+DGABP*BEX
49187           P(I,2)=DP(2)+DGABP*BEY
49188           P(I,3)=DP(3)+DGABP*BEZ
49189           P(I,4)=GA*(DP(4)+DBP)
49190   560   CONTINUE
49191       ENDIF
49192
49193 C...Weight with azimuthal distribution, if required.
49194       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
49195         DO 570 J=1,3
49196           DPT(1,J)=P(IM,J)
49197           DPT(2,J)=P(IAU,J)
49198           DPT(3,J)=P(N+1,J)
49199   570   CONTINUE
49200         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
49201         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
49202         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
49203         DO 580 J=1,3
49204           DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
49205           DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
49206   580   CONTINUE
49207         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
49208         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
49209         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
49210           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
49211      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
49212           IF(MAZIP.NE.0) THEN
49213             IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
49214      &      GOTO 550
49215           ENDIF
49216           IF(MAZIC.NE.0) THEN
49217             IF(MAZIC.EQ.N+2) CAD=-CAD
49218             IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
49219      &      .LT.PYR(0)) GOTO 550
49220           ENDIF
49221         ENDIF
49222       ENDIF
49223
49224 C...Azimuthal anisotropy due to interference with initial state partons.
49225       IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
49226      &K(N+2,2).EQ.21)) THEN
49227         III=IM-NS-1
49228         IF(ISII(III).GE.1) THEN
49229           IAZIID=N+1
49230           IF(K(N+1,2).NE.21) IAZIID=N+2
49231           IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49232      &    P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
49233           THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
49234           IF(III.EQ.2) THEIID=PARU(1)-THEIID
49235           PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
49236           HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
49237           CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
49238           PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
49239           IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
49240           IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
49241      &    .LT.PYR(0)) GOTO 550
49242         ENDIF
49243       ENDIF
49244
49245 C...Continue loop over partons that may branch, until none left.
49246       IF(IGM.GE.0) K(IM,1)=14
49247       N=N+NEP
49248       NEP=2
49249       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
49250         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
49251         IF(MSTU(21).GE.1) N=NS
49252         IF(MSTU(21).GE.1) RETURN
49253       ENDIF
49254       GOTO 280
49255
49256 C...Set information on imagined shower initiator.
49257   590 IF(NPA.GE.2) THEN
49258         K(NS+1,1)=11
49259         K(NS+1,2)=94
49260         K(NS+1,3)=IP1
49261         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
49262         K(NS+1,4)=NS+2
49263         K(NS+1,5)=NS+1+NPA
49264         IIM=1
49265       ELSE
49266         IIM=0
49267       ENDIF
49268
49269 C...Reconstruct string drawing information.
49270       DO 600 I=NS+1+IIM,N
49271         KQ=KCHG(PYCOMP(K(I,2)),2)
49272         IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
49273           K(I,1)=1
49274         ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
49275      &    IABS(K(I,2)).LE.18) THEN
49276           K(I,1)=1
49277         ELSEIF(K(I,1).LE.10) THEN
49278           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
49279           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
49280         ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
49281           ID1=MOD(K(I,4),MSTU(5))
49282           IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
49283           IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
49284      &    PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
49285           ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
49286           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49287           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
49288           K(ID1,4)=K(ID1,4)+MSTU(5)*I
49289           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
49290           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
49291           K(ID2,5)=K(ID2,5)+MSTU(5)*I
49292         ELSE
49293           ID1=MOD(K(I,4),MSTU(5))
49294           ID2=ID1+1
49295           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49296           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
49297           IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
49298             K(ID1,4)=K(ID1,4)+MSTU(5)*I
49299             K(ID1,5)=K(ID1,5)+MSTU(5)*I
49300           ELSE
49301             K(ID1,4)=0
49302             K(ID1,5)=0
49303           ENDIF
49304           K(ID2,4)=0
49305           K(ID2,5)=0
49306         ENDIF
49307   600 CONTINUE
49308
49309 C...Transformation from CM frame.
49310       IF(NPA.EQ.1) THEN
49311         THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
49312         PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
49313         MSTU(33)=1
49314         CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
49315       ELSEIF(NPA.EQ.2) THEN
49316         BEX=PS(1)/PS(4)
49317         BEY=PS(2)/PS(4)
49318         BEZ=PS(3)/PS(4)
49319         GA=PS(4)/PS(5)
49320         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
49321      &  /(1D0+GA)-P(IPA(1),4))
49322         THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
49323      &  +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
49324         PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
49325         MSTU(33)=1
49326         CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
49327       ELSE
49328         CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
49329      &  PS(3)/PS(4))
49330         MSTU(33)=1
49331         CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
49332       ENDIF
49333
49334 C...Decay vertex of shower.
49335       DO 620 I=NS+1,N
49336         DO 610 J=1,5
49337           V(I,J)=V(IP1,J)
49338   610   CONTINUE
49339   620 CONTINUE
49340
49341 C...Delete trivial shower, else connect initiators.
49342       IF(N.LE.NS+NPA+IIM) THEN
49343         N=NS
49344       ELSE
49345         DO 630 IP=1,NPA
49346           K(IPA(IP),1)=14
49347           K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
49348           K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
49349           K(NS+IIM+IP,3)=IPA(IP)
49350           IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
49351           IF(K(NS+IIM+IP,1).NE.1) THEN
49352             K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
49353             K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
49354           ENDIF
49355   630   CONTINUE
49356       ENDIF
49357
49358       RETURN
49359       END
49360
49361 C*********************************************************************
49362
49363 C...PYMAEL
49364 C...Auxiliary to PYSHOW.
49365 C...Matrix elements for gluon (or photon) emission from
49366 C...a two-body state; to be used by the parton shower routine.
49367 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
49368 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
49369 C...      = (alpha-strong/2 pi) * CF * PYMAEL,
49370 C...i.e. normalization is such that one recovers the familiar
49371 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
49372 C...Coupling structure:
49373 C...NI =  6- 9 : eikonal soft-gluon expression (spin-independent)
49374 C...   = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
49375 C...   = 16-19 : q -> q V
49376 C...   = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
49377 C...   = 26-29 : q -> q S
49378 C...   = 31-34 : V -> ~q ~qbar  (~q = squark)
49379 C...   = 36-39 : ~q -> ~q V
49380 C...   = 41-44 : S -> ~q ~qbar
49381 C...   = 46-49 : ~q -> ~q S
49382 C...   = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
49383 C...   = 56-59 : ~q -> q chi
49384 C...   = 61-64 : q -> ~q chi
49385 C...   = 66-69 : ~g -> q ~qbar
49386 C...   = 71-74 : ~q -> q ~g
49387 C...   = 76-79 : q -> ~q ~g
49388 C...   = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
49389 C...Note that the order of the decay products is important.
49390 C...In each set of four, the variants are ordered as:
49391 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
49392 C...       = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
49393 C...       = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
49394 C...       = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
49395
49396       FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
49397
49398 C...Double precision and integer declarations.
49399       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49400       IMPLICIT INTEGER(I-N)
49401
49402 C...Check input values. Return zero outside allowed phase space.
49403       PYMAEL=0D0
49404       IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
49405       IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
49406       IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
49407       IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
49408      &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
49409       ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
49410
49411 C...Initial values and flags.
49412       ICLASS=NI/5
49413       ICOMBI=NI-5*ICLASS
49414       ISSET1=0
49415       ISSET2=0
49416       ISSET4=0
49417
49418 C... Phase space.
49419       PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
49420
49421 C...Eikonal expression; also acts as default.
49422       IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
49423         RLO=PS
49424         IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
49425           ANUM=0D0
49426         ELSEIF(ICOMBI.EQ.2) THEN
49427           ANUM=(2D0-X1-X2)**2
49428         ELSEIF(ICOMBI.EQ.3) THEN
49429           ANUM=ALPCOR*(2D0-X1-X2)**2
49430         ELSE
49431           ANUM=0.5D0*(2D0-X1-X2)**2
49432         ENDIF
49433         RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
49434      &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
49435      &       R1**2/(1D0+R2**2-R1**2-X2)**2-
49436      &       R2**2/(1D0+R1**2-R2**2-X1)**2)
49437         ICOMBI=0
49438
49439 C...V -> q qbar (V = gamma*/Z0/W+-/...).
49440       ELSEIF(ICLASS.EQ.2) THEN
49441         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49442         RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49443         RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
49444      &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
49445      &       +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
49446      &       +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
49447      &       -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49448      &       -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
49449      &       +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
49450      &       (-1+R1**2-R2**2+X2)**2
49451         RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49452      &       +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49453      &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
49454      &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49455      &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
49456      &       -X1-X2)**2+X1*(2-X1-X2)**2)/
49457      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49458         RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
49459      &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
49460      &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
49461      &       -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
49462      &       (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
49463         RFO1=RFO1/2.D0
49464         ISSET1=1
49465         ENDIF
49466         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49467         RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49468         RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
49469      &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
49470      &       +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
49471      &       -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
49472      &       +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
49473      &       -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
49474      &       +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
49475         RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49476      &       -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49477      &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
49478      &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49479      &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
49480      &       -X1-X2)**2+X1*(2-X1-X2)**2)/
49481      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49482         RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
49483      &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
49484      &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
49485      &       -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49486      &       +X2)/(-1-R1**2+R2**2+X1)**2
49487         RFO2=RFO2/2.D0
49488         ISSET2=1
49489         ENDIF
49490         IF(ICOMBI.EQ.4) THEN
49491         RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
49492         RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
49493      &       -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
49494      &       +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
49495      &       (-1-R1**2+R2**2+X1)**2
49496         RFO4=RFO4
49497      &       -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
49498      &       -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
49499      &       -R1**2*X2**2+X1*X2**2)/
49500      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49501         RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
49502      &       -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
49503      &       +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
49504      &       (-1+R1**2-R2**2+X2)**2
49505         RFO4=RFO4/2.D0
49506         ISSET4=1
49507         ENDIF
49508
49509 C...q -> q V.
49510       ELSEIF(ICLASS.EQ.3) THEN
49511         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49512         RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
49513      &        +R1**2*R2**2-2D0*R2**4)
49514         RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
49515      &       -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
49516      &       +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
49517      &       +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
49518      &       +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
49519      &       -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
49520      &       -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49521         RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
49522      &       +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49523      &       -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
49524      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49525      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49526         RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
49527      &       +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
49528      &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49529      &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
49530      &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49531      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
49532      &       +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
49533         ISSET1=1
49534         ENDIF
49535         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49536         RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
49537      &        +R1**2*R2**2-2D0*R2**4)
49538         RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
49539      &       +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
49540      &       -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
49541      &       -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
49542      &       -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
49543      &       +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
49544      &       -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49545         RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
49546      &       +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49547      &       -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
49548      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49549      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49550         RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49551      &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
49552      &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49553      &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
49554      &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49555      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49556      &       +X1*X2**2)/(-2+X1+X2)**2
49557         ISSET2=1
49558         ENDIF
49559         IF(ICOMBI.EQ.4) THEN
49560         RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
49561         RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
49562      &       -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
49563      &       -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
49564      &       +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
49565      &       +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49566         RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
49567      &       -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
49568      &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49569      &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49570         RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49571      &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
49572      &       -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
49573      &       -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49574      &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49575      &       +X1*X2**2)/(2-X1-X2)**2
49576         ISSET4=1
49577         ENDIF
49578
49579 C...S -> q qbar    (S = h0/H0/A0/H+-/...).
49580       ELSEIF(ICLASS.EQ.4) THEN
49581         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49582         RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
49583         RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49584      &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49585      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49586      &       -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
49587      &       +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
49588      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49589      &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49590      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49591      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49592         ISSET1=1
49593         ENDIF
49594         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49595         RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
49596         RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49597      &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49598      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49599      &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49600      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49601      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49602      &       +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
49603      &       -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
49604      &       -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49605      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49606         ISSET2=1
49607         ENDIF
49608         IF(ICOMBI.EQ.4) THEN
49609         RLO4=PS*(1D0-R1**2-R2**2)
49610         RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49611      &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49612      &       -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49613      &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49614      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49615      &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
49616      &       +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49617         ISSET4=1
49618         ENDIF
49619
49620 C...q -> q S.
49621       ELSEIF(ICLASS.EQ.5) THEN
49622         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49623         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49624         RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49625      &       -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49626      &       +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
49627      &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49628      &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
49629      &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49630      &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49631      &       (-1+R1**2-R2**2+X2)**2
49632         ISSET1=1
49633         ENDIF
49634         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49635         RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49636         RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49637      &       +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49638      &       +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
49639      &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49640      &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
49641      &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49642      &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49643      &       (-1+R1**2-R2**2+X2)**2
49644         ISSET2=1
49645         ENDIF
49646         IF(ICOMBI.EQ.4) THEN
49647         RLO4=PS*(1D0+R1**2-R2**2)
49648         RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
49649      &       -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49650      &       +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
49651      &       -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49652      &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49653      &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49654         ISSET4=1
49655         ENDIF
49656
49657 C...V -> ~q ~qbar  (~q = squark).
49658       ELSEIF(ICLASS.EQ.6) THEN
49659         RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49660         RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
49661      &       (-1-R1**2+R2**2+X1)**2
49662      &       -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
49663      &       (-1-R1**2+R2**2+X1)
49664      &       +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
49665      &       /(-1+R1**2-R2**2+X2)**2
49666      &       -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
49667      &       (-1+R1**2-R2**2+X2)
49668      &       -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
49669      &       +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
49670      &       -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
49671      &       +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49672         ISSET1=1
49673
49674 C...~q -> ~q V.
49675       ELSEIF(ICLASS.EQ.7) THEN
49676         RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49677         RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
49678      &       -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
49679      &       (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
49680      &       (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49681      &       +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
49682      &       -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
49683      &       (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
49684      &       (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
49685      &       +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
49686      &       +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
49687      &       (3*(-2+X1+X2))
49688         RFO1=3D0*RFO1/8D0
49689         ISSET1=1
49690
49691 C...S -> ~q ~qbar.
49692       ELSEIF(ICLASS.EQ.8) THEN
49693         RLO1=PS
49694         RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49695      &       +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
49696      &       +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
49697      &       -R1**2*X2**2+X1*X2**2)/
49698      &       (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
49699         RFO1=2D0*RFO1
49700         ISSET1=1
49701
49702 C...~q -> ~q S.
49703       ELSEIF(ICLASS.EQ.9) THEN
49704         RLO1=PS
49705         RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49706      &       +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49707      &       -(X1+X2)/(-2+X1+X2)**2
49708         ISSET1=1
49709
49710 C...chi -> q ~qbar   (chi = neutralino/chargino).
49711       ELSEIF(ICLASS.EQ.10) THEN
49712         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49713         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49714         RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49715      &       +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
49716      &       -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49717      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49718      &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49719      &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49720      &       (-1+R1**2-R2**2+X2)**2
49721         ISSET1=1
49722         ENDIF
49723         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49724         RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
49725         RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
49726      &       +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
49727      &       -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
49728      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49729      &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49730      &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49731      &       (-1+R1**2-R2**2+X2)**2
49732         ISSET2=1
49733         ENDIF
49734         IF(ICOMBI.EQ.4) THEN
49735         RLO4=PS*(1+R1**2-R2**2)
49736         RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49737      &       +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
49738      &       +X2+R1**2*X2-X1*X2/2)/
49739      &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49740      &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49741      &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49742         ISSET4=1
49743         ENDIF
49744
49745 C...~q -> q chi.
49746       ELSEIF(ICLASS.EQ.11) THEN
49747         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49748         RLO1=PS*(1D0-(R1+R2)**2)
49749         RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49750      &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49751      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49752      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49753      &       +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49754      &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49755      &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49756         ISSET1=1
49757         ENDIF
49758         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49759         RLO2=PS*(1D0-(R1-R2)**2)
49760         RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
49761      &       (-2+X1+X2)**2
49762      &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49763      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49764      &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49765      &       +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
49766      &       +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49767      &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49768         ISSET2=1
49769         ENDIF
49770         IF(ICOMBI.EQ.4) THEN
49771         RLO4=PS*(1D0-R1**2-R2**2)
49772         RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49773      &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
49774      &       +3*R1**2*X2-R2**2*X2-X1*X2)/
49775      &       (-1+R1**2-R2**2+X2)**2
49776      &       -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49777      &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49778      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
49779         ISSET4=1
49780         ENDIF
49781
49782 C...q -> ~q chi.
49783       ELSEIF(ICLASS.EQ.12) THEN
49784         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49785         RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49786         RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49787      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
49788      &       -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
49789      &       (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
49790      &       +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49791      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
49792         ISSET1=1
49793         END IF
49794         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49795         RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49796         RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
49797      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
49798      &       -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49799      &       (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49800      &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49801      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
49802         ISSET2=1
49803         END IF
49804         IF(ICOMBI.EQ.4) THEN
49805         RLO4=PS*(1D0-R1**2+R2**2)
49806         RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49807      &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
49808      &       -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
49809      &       (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
49810      &       +R1**2*X2-X1*X2/2-X2**2/2)/
49811      &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
49812         ISSET4=1
49813         END IF
49814
49815 C...~g -> q ~qbar.
49816       ELSEIF(ICLASS.EQ.13) THEN
49817         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49818         RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49819         RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
49820      &       -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
49821      &       -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
49822      &       +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
49823      &       +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49824      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
49825      &       -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
49826      &       +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
49827      &       +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
49828      &       +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
49829      &       -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
49830      &       -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49831      &       (3*(-1+R1**2-R2**2+X2)**2)
49832         RFO1=3D0*RFO1/4D0
49833         ISSET1=1
49834         ENDIF
49835         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49836         RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49837         RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
49838      &       -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
49839      &       +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49840      &       +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
49841      &       +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
49842      &       (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
49843      &       +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
49844      &       +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
49845      &       -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
49846      &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49847      &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
49848      &       +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
49849      &       +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49850      &       (3*(-1+R1**2-R2**2+X2)**2)
49851         RFO2=3D0*RFO2/4D0
49852         ISSET2=1
49853         ENDIF
49854         IF(ICOMBI.EQ.4) THEN
49855         RLO4=PS*(1D0+R1**2-R2**2)
49856         RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
49857      &       -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
49858      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
49859      &       +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
49860      &       +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
49861      &       +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49862      &       (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
49863      &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49864      &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
49865      &       +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49866      &       (3*(-1+R1**2-R2**2+X2)**2)
49867         RFO4=3D0*RFO4/8D0
49868         ISSET4=1
49869         ENDIF
49870
49871 C...~q -> q ~g.
49872       ELSEIF(ICLASS.EQ.14) THEN
49873         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49874         RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
49875         RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49876      &       -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49877      &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49878      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
49879      &       -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
49880      &       -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
49881      &       -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49882      &       -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49883      &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49884      &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49885      &       +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
49886      &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
49887      &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49888         RFO1=RFO1
49889      &       +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49890      &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49891      &       +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49892         RFO1=9D0*RFO1/64D0
49893         ISSET1=1
49894         ENDIF
49895         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49896         RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
49897         RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49898      &       -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49899      &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49900      &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
49901      &       +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
49902      &       -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
49903      &       -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
49904      &       -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
49905      &       +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49906      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49907         RFO2=RFO2
49908      &       +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
49909      &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
49910      &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49911      &       +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
49912      &       +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
49913      &       -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49914         RFO2=9D0*RFO2/64D0
49915         ISSET2=1
49916         ENDIF
49917         IF(ICOMBI.EQ.4) THEN
49918         RLO4=PS*(1-R1**2-R2**2)
49919         RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
49920      &       +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49921      &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49922      &       -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49923      &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49924      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
49925      &       -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
49926      &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49927      &       +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
49928      &       +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
49929      &       ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
49930         RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49931      &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49932      &       (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
49933         RFO4=9D0*RFO4/128D0
49934         ISSET4=1
49935         ENDIF
49936
49937 C...q -> ~q ~g.
49938       ELSEIF(ICLASS.EQ.15) THEN
49939         IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49940         RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49941         RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49942      &       +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
49943      &       +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
49944      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
49945      &       -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
49946      &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49947      &       (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
49948      &       -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
49949      &       +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49950         RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
49951      &       +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
49952      &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
49953      &       -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49954      &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49955         RFO1=9D0*RFO1/32D0
49956         ISSET1=1
49957         END IF
49958         IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49959         RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49960         RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
49961      &       +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
49962      &       +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
49963      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
49964      &       +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
49965      &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49966      &       (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
49967      &       +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
49968      &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49969         RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
49970      &       +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49971      &       (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49972      &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49973      &       (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49974         RFO2=9D0*RFO2/32D0
49975         ISSET2=1
49976         END IF
49977         IF(ICOMBI.EQ.4) THEN
49978         RLO4=PS*(1D0-R1**2+R2**2)
49979         RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49980      &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
49981      &       -R2**2*X2/2-X1*X2/2)/
49982      &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
49983      &       -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
49984      &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49985      &       +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
49986      &       -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49987         RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
49988      &       -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
49989      &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49990      &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49991         RFO4=9D0*RFO4/64D0
49992         ISSET4=1
49993         END IF
49994
49995 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
49996       ELSEIF(ICLASS.EQ.16) THEN
49997         RLO=PS
49998         IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
49999           ANUM=0D0
50000         ELSEIF(ICOMBI.EQ.2) THEN
50001           ANUM=(2D0-X1-X2)**2
50002         ELSEIF(ICOMBI.EQ.3) THEN
50003           ANUM=ALPCOR*(2D0-X1-X2)**2
50004         ELSE
50005           ANUM=0.5D0*(2D0-X1-X2)**2
50006         ENDIF
50007         RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
50008      &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
50009      &       R1**2/(1D0+R2**2-R1**2-X2)**2-
50010      &       R2**2/(1D0+R1**2-R2**2-X1)**2)
50011         RFO=9D0*RFO/4D0
50012         ICOMBI=0
50013       ENDIF
50014
50015 C...Find relevant LO and FO expression.
50016       IF(ICOMBI.EQ.0) THEN
50017       ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
50018         RLO=RLO1
50019         RFO=RFO1
50020       ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
50021         RLO=RLO2
50022         RFO=RFO2
50023       ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50024         RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
50025         RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
50026       ELSEIF(ISSET4.EQ.1) THEN
50027         RLO=RLO4
50028         RFO=RFO4
50029       ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50030         RLO=0.5D0*(RLO1+RLO2)
50031         RFO=0.5D0*(RFO1+RFO2)
50032       ELSEIF(ISSET1.EQ.1) THEN
50033         RLO=RLO1
50034         RFO=RFO1
50035       ELSE
50036         CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
50037         RLO=1D0
50038         RFO=0D0
50039       ENDIF
50040
50041 C...Output.
50042       PYMAEL=RFO/RLO
50043
50044       RETURN
50045       END
50046
50047 C*********************************************************************
50048
50049 C...PYBOEI
50050 C...Modifies an event so as to approximately take into account
50051 C...Bose-Einstein effects according to a simple phenomenological
50052 C...parametrization.
50053
50054       SUBROUTINE PYBOEI(NSAV)
50055
50056 C...Double precision and integer declarations.
50057       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50058       IMPLICIT INTEGER(I-N)
50059       INTEGER PYK,PYCHGE,PYCOMP
50060 C...Parameter statement to help give large particle numbers.
50061       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50062      &KEXCIT=4000000,KDIMEN=5000000)
50063 C...Commonblocks.
50064       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50065       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50066       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50067       COMMON/PYINT1/MINT(400),VINT(400)
50068       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
50069 C...Local arrays and data.
50070       DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
50071      &BEIW(100),BEI3W(100)
50072       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
50073 C...Statement function: squared invariant mass.
50074       SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
50075      &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
50076
50077 C...Boost event to overall CM frame. Calculate CM energy.
50078       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
50079       DO 100 J=1,4
50080         DPS(J)=0D0
50081   100 CONTINUE
50082       DO 120 I=1,N
50083         KFA=IABS(K(I,2))
50084         IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
50085      &  .AND.K(I,3).GT.0) THEN
50086           KFMA=IABS(K(K(I,3),2))
50087           IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
50088         ENDIF
50089         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
50090         DO 110 J=1,4
50091           DPS(J)=DPS(J)+P(I,J)
50092   110   CONTINUE
50093   120 CONTINUE
50094       CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
50095      &-DPS(3)/DPS(4))
50096       PECM=0D0
50097       DO 130 I=1,N
50098         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
50099   130 CONTINUE
50100
50101 C...Check if we have separated strings
50102
50103 C...Reserve copy of particles by species at end of record.
50104       IWP=0
50105       IWN=0
50106       NBE(0)=N+MSTU(3)
50107       NMAX=NBE(0)
50108       SMMIN=PECM
50109       DO 190 IBE=1,MIN(10,MSTJ(52)+1)
50110         NBE(IBE)=NBE(IBE-1)
50111         DO 180 I=NSAV+1,N
50112           IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
50113             DO 140 IIBE=1,IBE-1
50114               IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
50115   140       CONTINUE
50116           ELSE
50117             IF(K(I,2).NE.KFBE(IBE)) GOTO 180
50118           ENDIF
50119           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
50120           IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
50121             CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
50122             RETURN
50123           ENDIF
50124           NBE(IBE)=NBE(IBE)+1
50125           NMAX=NBE(IBE)
50126           K(NBE(IBE),1)=I
50127           K(NBE(IBE),2)=0
50128           K(NBE(IBE),3)=0
50129           K(NBE(IBE),4)=0
50130           K(NBE(IBE),5)=0
50131           P(NBE(IBE),1)=0.0D0
50132           P(NBE(IBE),2)=0.0D0
50133           P(NBE(IBE),3)=0.0D0
50134           P(NBE(IBE),4)=0.0D0
50135           P(NBE(IBE),5)=0.0D0
50136           SMMIN=MIN(SMMIN,P(I,5))
50137 C...Check if particles comes from different W's or Z's
50138           IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
50139             IM=I
50140   150       IF(K(IM,3).GT.0) THEN
50141               IM=K(IM,3)
50142               IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
50143               K(NBE(IBE),5)=IM
50144               IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
50145               IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
50146               IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
50147               IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
50148             ENDIF
50149           ENDIF
50150 C...Check if particles comes from different strings.
50151           IF(PARJ(94).GT.0.0D0) THEN
50152             IM=I
50153   160       IF(K(IM,3).GT.0) THEN
50154               IM=K(IM,3)
50155               IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
50156               K(NBE(IBE),5)=IM
50157             ENDIF
50158           ENDIF
50159           DO 170 J=1,3
50160             P(NBE(IBE),J)=0D0
50161             V(NBE(IBE),J)=0D0
50162   170     CONTINUE
50163           P(NBE(IBE),5)=-1.0D0
50164   180   CONTINUE
50165   190 CONTINUE
50166       IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
50167
50168 C...Calculate separation between W+ and W- or between two Z0's.
50169 C...No separation if there has been re-connections.
50170       SIGW=PARJ(93)
50171       IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
50172         IF(K(IWP,2).EQ.23) THEN
50173           DMW=PMAS(23,1)
50174           DGW=PMAS(23,2)
50175         ELSE
50176           DMW=PMAS(24,1)
50177           DGW=PMAS(24,2)
50178         ENDIF
50179         DMP=P(IWP,5)
50180         DMN=P(IWN,5)
50181         TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
50182         TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
50183         TAUP=-TAUPD*LOG(PYR(IDUM))
50184         TAUN=-TAUND*LOG(PYR(IDUM))
50185         DXP=TAUP*PYP(IWP,8)/DMP
50186         DXN=TAUN*PYP(IWN,8)/DMN
50187         DX=DXP+DXN
50188         SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
50189         IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
50190       ENDIF
50191
50192 C...Add separation between strings.
50193       IF(PARJ(94).GT.0.0D0) THEN
50194         SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
50195         IWP=-1
50196         IWN=-1
50197       ENDIF
50198
50199       IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
50200         DO 220 IBE=1,MIN(9,MSTJ(52))
50201           DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
50202             Q2MIN=PECM**2
50203             I1=K(I1M,1)
50204             DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
50205               IF(I2M.EQ.I1M) GOTO 200
50206               I2=K(I2M,1)
50207               Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
50208      &        (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
50209      &        (P(I1,5)+P(I2,5))**2
50210               IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
50211                 Q2MIN=Q2
50212               ENDIF
50213   200       CONTINUE
50214             P(I1M,5)=Q2MIN
50215   210     CONTINUE
50216   220   CONTINUE
50217       ENDIF
50218
50219 C...Tabulate integral for subsequent momentum shift.
50220       DO 400 IBE=1,MIN(9,MSTJ(52))
50221         IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
50222         IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
50223      &  .LE.1) GOTO 270
50224         IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
50225      &  NBE(7)-NBE(6)).LE.1) GOTO 270
50226         IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
50227         IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
50228         IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
50229         IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
50230         IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
50231         QDEL=0.1D0*MIN(PMHQ,PARJ(93))
50232         QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
50233         QDELW=0.1D0*MIN(PMHQ,SIGW)
50234         QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
50235         IF(MSTJ(51).EQ.1) THEN
50236           NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
50237           NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
50238           NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
50239           NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
50240           BEEX=EXP(0.5D0*QDEL/PARJ(93))
50241           BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
50242           BEEXW=EXP(0.5D0*QDELW/SIGW)
50243           BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
50244           BERT=EXP(-QDEL/PARJ(93))
50245           BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
50246           BERTW=EXP(-QDELW/SIGW)
50247           BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
50248         ELSE
50249           NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
50250           NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
50251           NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
50252           NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
50253         ENDIF
50254         DO 230 IBIN=1,NBIN
50255           QBIN=QDEL*(IBIN-0.5D0)
50256           BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50257           IF(MSTJ(51).EQ.1) THEN
50258             BEEX=BEEX*BERT
50259             BEI(IBIN)=BEI(IBIN)*BEEX
50260           ELSE
50261             BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
50262           ENDIF
50263           IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
50264   230   CONTINUE
50265         DO 240 IBIN=1,NBIN3
50266           QBIN=QDEL3*(IBIN-0.5D0)
50267           BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50268           IF(MSTJ(51).EQ.1) THEN
50269             BEEX3=BEEX3*BERT3
50270             BEI3(IBIN)=BEI3(IBIN)*BEEX3
50271           ELSE
50272             BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
50273           ENDIF
50274           IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
50275   240   CONTINUE
50276         DO 250 IBIN=1,NBINW
50277           QBIN=QDELW*(IBIN-0.5D0)
50278           BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50279           IF(MSTJ(51).EQ.1) THEN
50280             BEEXW=BEEXW*BERTW
50281             BEIW(IBIN)=BEIW(IBIN)*BEEXW
50282           ELSE
50283             BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
50284           ENDIF
50285           IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
50286   250   CONTINUE
50287         DO 260 IBIN=1,NBIN3W
50288           QBIN=QDEL3W*(IBIN-0.5D0)
50289           BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
50290      &    SQRT(QBIN**2+PMHQ**2)
50291           IF(MSTJ(51).EQ.1) THEN
50292             BEEX3W=BEEX3W*BERT3W
50293             BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
50294           ELSE
50295             BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
50296           ENDIF
50297           IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
50298   260   CONTINUE
50299
50300 C...Loop through particle pairs and find old relative momentum.
50301   270   DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
50302           I1=K(I1M,1)
50303           DO 380 I2M=I1M+1,NBE(IBE)
50304             IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
50305             IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
50306             I2=K(I2M,1)
50307             Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
50308      &      P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
50309             IF(Q2OLD.LE.0.0D0) GOTO 380
50310             QOLD=SQRT(Q2OLD)
50311
50312 C...Calculate new relative momentum.
50313             QMOV=0.0D0
50314             QMOV3=0.0D0
50315             QMOVW=0.0D0
50316             QMOV3W=0.0D0
50317             IF(QOLD.LT.1D-3*QDEL) THEN
50318               GOTO 280
50319             ELSEIF(QOLD.LE.QDEL) THEN
50320               QMOV=QOLD/3D0
50321             ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
50322               RBIN=QOLD/QDEL
50323               IBIN=RBIN
50324               RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
50325               QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
50326      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
50327             ELSE
50328               QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50329             ENDIF
50330   280       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
50331             IF(QOLD.LT.1D-3*QDEL3) THEN
50332               GOTO 290
50333             ELSEIF(QOLD.LE.QDEL3) THEN
50334               QMOV3=QOLD/3D0
50335             ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
50336               RBIN3=QOLD/QDEL3
50337               IBIN3=RBIN3
50338               RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
50339               QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
50340      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
50341             ELSE
50342               QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50343             ENDIF
50344   290       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
50345             RSCALE=1.0D0
50346             IF(MSTJ(54).EQ.2)
50347      &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
50348             IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
50349      &      K(I1M,5).EQ.K(I2M,5)) GOTO 320
50350
50351             IF(QOLD.LT.1D-3*QDELW) THEN
50352               GOTO 300
50353             ELSEIF(QOLD.LE.QDELW) THEN
50354               QMOVW=QOLD/3D0
50355             ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
50356               RBINW=QOLD/QDELW
50357               IBINW=RBINW
50358               RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
50359               QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
50360      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
50361             ELSE
50362               QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50363             ENDIF
50364   300       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
50365             IF(QOLD.LT.1D-3*QDEL3W) THEN
50366               GOTO 310
50367             ELSEIF(QOLD.LE.QDEL3W) THEN
50368               QMOV3W=QOLD/3D0
50369             ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
50370               RBIN3W=QOLD/QDEL3W
50371               IBIN3W=RBIN3W
50372               RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
50373               QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
50374      &        BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50375             ELSE
50376               QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50377             ENDIF
50378   310       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
50379             IF(MSTJ(54).EQ.2)
50380      &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
50381
50382   320       CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
50383             DO 330 J=1,3
50384               P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
50385               P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
50386   330       CONTINUE
50387             IF(MSTJ(54).GE.1) THEN
50388               CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
50389               DO 340 J=1,3
50390                 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
50391                 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
50392   340         CONTINUE
50393             ELSEIF(MSTJ(54).LE.-1) THEN
50394               EDEL=P(I1,4)+P(I2,4)-
50395      &        SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
50396               A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50397      &        (P(I1,3)-P(I2,3))**2
50398               WMAX=-1.0D20
50399               MI3=0
50400               MI4=0
50401               S12=SDIP(I1,I2)
50402               SM1=(P(I1,5)+SMMIN)**2
50403               DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50404                 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
50405                 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
50406                 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50407      &          K(I3M,5).NE.K(I1M,5)) GOTO 360
50408                 I3=K(I3M,1)
50409                 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
50410                 S13=SDIP(I1,I3)
50411                 S23=SDIP(I2,I3)
50412                 SM3=(P(I3,5)+SMMIN)**2
50413                 IF(MSTJ(54).EQ.-2) THEN
50414                   WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
50415      &            S23*MIN(SM1,SM3))*SM1)
50416                 ELSE
50417                   WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
50418      &            (P(I1,3)+P(I2,3)+P(I3,3))**2-
50419      &            (P(I1,2)+P(I2,2)+P(I3,2))**2-
50420      &            (P(I1,1)+P(I2,1)+P(I3,1))**2)
50421                 ENDIF
50422                 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
50423                   IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
50424      &                 GOTO 360
50425                 ELSE
50426                   IF(WMAX*WI.GE.1.0) GOTO 360
50427                 ENDIF
50428                 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
50429                   IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
50430                   IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
50431                   IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50432      &            K(I4M,5).NE.K(I1M,5)) GOTO 350
50433                   I4=K(I4M,1)
50434                   IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
50435      &            GOTO 350
50436                   IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
50437      &            (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50438      &            (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
50439      &            GOTO 350
50440                   IF(MSTJ(54).EQ.-2) THEN
50441                     S14=SDIP(I1,I4)
50442                     S24=SDIP(I2,I4)
50443                     S34=SDIP(I3,I4)
50444                     W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
50445                     W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
50446                     W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
50447                     W=MIN(W,MIN(S23,S24)*S13*S14)
50448                     W=1.0D0/W
50449                   ELSE
50450 C...weight=1-cos(theta)/mtot2
50451                     S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
50452      &              (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
50453      &              (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
50454      &              (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
50455                     W=1.0D0/S1234
50456                     IF(W.LE.WMAX) GOTO 350
50457                   ENDIF
50458                   IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
50459      &            W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
50460                   IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
50461      &            W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
50462                   IF(W.LE.WMAX) GOTO 350
50463                   MI3=I3M
50464                   MI4=I4M
50465                   WMAX=W
50466   350           CONTINUE
50467   360         CONTINUE
50468               IF(MI4.EQ.0) GOTO 380
50469               I3=K(MI3,1)
50470               I4=K(MI4,1)
50471               EOLD=P(I3,4)+P(I4,4)
50472               ENEW=EOLD+EDEL
50473               P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50474      &        (P(I3,3)+P(I4,3))**2
50475               Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
50476               Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
50477               CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
50478               DO 370 J=1,3
50479                 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
50480                 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
50481   370         CONTINUE
50482             ENDIF
50483   380     CONTINUE
50484   390   CONTINUE
50485   400 CONTINUE
50486
50487 C...Shift momenta and recalculate energies.
50488       ESUMP=0.0D0
50489       ESUM=0.0D0
50490       PROD=0.0D0
50491       DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50492         I=K(IM,1)
50493         ESUMP=ESUMP+P(I,4)
50494         DO 410 J=1,3
50495           P(I,J)=P(I,J)+P(IM,J)
50496   410   CONTINUE
50497         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50498         ESUM=ESUM+P(I,4)
50499         DO 420 J=1,3
50500           PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50501   420   CONTINUE
50502   430 CONTINUE
50503
50504       PARJ(96)=0.0D0
50505       IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
50506   440   ALPHA=(ESUMP-ESUM)/PROD
50507         PARJ(96)=PARJ(96)+ALPHA
50508         PROD=0.0D0
50509         ESUM=0.0D0
50510         DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50511           I=K(IM,1)
50512           DO 450 J=1,3
50513             P(I,J)=P(I,J)+ALPHA*V(IM,J)
50514   450     CONTINUE
50515           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50516           ESUM=ESUM+P(I,4)
50517           DO 460 J=1,3
50518             PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50519   460     CONTINUE
50520   470   CONTINUE
50521         IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
50522      &  GOTO 440
50523       ENDIF
50524
50525 C...Rescale all momenta for energy conservation.
50526       PES=0D0
50527       PQS=0D0
50528       DO 480 I=1,N
50529         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
50530         PES=PES+P(I,4)
50531         PQS=PQS+P(I,5)**2/P(I,4)
50532   480 CONTINUE
50533       PARJ(95)=PES-PECM
50534       FAC=(PECM-PQS)/(PES-PQS)
50535       DO 500 I=1,N
50536         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
50537         DO 490 J=1,3
50538           P(I,J)=FAC*P(I,J)
50539   490   CONTINUE
50540         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50541   500 CONTINUE
50542
50543 C...Boost back to correct reference frame.
50544   510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
50545       DO 520 I=1,N
50546         IF(K(I,1).LT.0) K(I,1)=-K(I,1)
50547   520 CONTINUE
50548
50549       RETURN
50550       END
50551
50552 C*********************************************************************
50553
50554 C...PYBESQ
50555 C...Calculates the momentum shift in a system of two particles assuming
50556 C...the relative momentum squared should be shifted to Q2NEW. NI is the
50557 C...last position occupied in /PYJETS/.
50558
50559       SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
50560
50561 C...Double precision and integer declarations.
50562       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50563       IMPLICIT INTEGER(I-N)
50564       INTEGER PYK,PYCHGE,PYCOMP
50565 C...Parameter statement to help give large particle numbers.
50566       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50567      &KEXCIT=4000000,KDIMEN=5000000)
50568 C...Commonblocks.
50569       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50570       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50571       SAVE /PYJETS/,/PYDAT1/
50572 C...Local arrays and data.
50573       DIMENSION DP(5)
50574       SAVE HC1
50575
50576       IF(MSTJ(55).EQ.0) THEN
50577         DQ2=Q2NEW-Q2OLD
50578         DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50579      &  (P(I1,3)-P(I2,3))**2
50580         DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
50581      &  -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
50582         SE=P(I1,4)+P(I2,4)
50583         DE=P(I1,4)-P(I2,4)
50584         DQ2SE=DQ2+SE**2
50585         DA=SE*DE*DP12-DP2*DQ2SE
50586         DB=DP2*DQ2SE-DP12**2
50587         HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
50588         DO 100 J=1,3
50589           PD=HA*(P(I1,J)-P(I2,J))
50590           P(NI+1,J)=PD
50591           P(NI+2,J)=-PD
50592   100   CONTINUE
50593         RETURN
50594       ENDIF
50595
50596       K(NI+1,1)=1
50597       K(NI+2,1)=1
50598       DO 110 J=1,5
50599         P(NI+1,J)=P(I1,J)
50600         P(NI+2,J)=P(I2,J)
50601         DP(J)=P(I1,J)+P(I2,J)
50602   110 CONTINUE
50603
50604 C...Boost to cms and rotate first particle to z-axis
50605       CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
50606      &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
50607       PHI=PYANGL(P(NI+1,1),P(NI+1,2))
50608       THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
50609       S=Q2NEW+(P(I1,5)+P(I2,5))**2
50610       PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
50611       P(NI+1,1)=0.0D0
50612       P(NI+1,2)=0.0D0
50613       P(NI+1,3)=PZ
50614       P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
50615       P(NI+2,1)=0.0D0
50616       P(NI+2,2)=0.0D0
50617       P(NI+2,3)=-PZ
50618       P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
50619       DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
50620       CALL PYROBO(NI+1,NI+2,THE,PHI,
50621      &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
50622
50623       DO 120 J=1,3
50624         P(NI+1,J)=P(NI+1,J)-P(I1,J)
50625         P(NI+2,J)=P(NI+2,J)-P(I2,J)
50626   120 CONTINUE
50627
50628       RETURN
50629       END
50630
50631 C*********************************************************************
50632
50633 C...PYMASS
50634 C...Gives the mass of a particle/parton.
50635
50636       FUNCTION PYMASS(KF)
50637
50638 C...Double precision and integer declarations.
50639       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50640       IMPLICIT INTEGER(I-N)
50641       INTEGER PYK,PYCHGE,PYCOMP
50642 C...Commonblocks.
50643       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50644       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50645       SAVE /PYDAT1/,/PYDAT2/
50646
50647 C...Reset variables. Compressed code. Special case for popcorn diquarks.
50648       PYMASS=0D0
50649       KFA=IABS(KF)
50650       KC=PYCOMP(KF)
50651       IF(KC.EQ.0) THEN
50652         MSTJ(93)=0
50653         RETURN
50654       ENDIF
50655
50656 C...Guarantee use of constituent masses for internal checks.
50657       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
50658      &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
50659         IF(KFA.LE.5) THEN
50660           PYMASS=PARF(100+KFA)
50661           IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
50662         ELSEIF(KFA.LE.10) THEN
50663           PYMASS=PMAS(KFA,1)
50664         ELSEIF(MSTJ(93).EQ.1) THEN
50665           PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
50666         ELSE
50667           PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
50668         ENDIF
50669
50670 C...Other masses can be read directly off table.
50671       ELSE
50672         PYMASS=PMAS(KC,1)
50673       ENDIF
50674
50675 C...Optional mass broadening according to truncated Breit-Wigner
50676 C...(either in m or in m^2).
50677       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
50678         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
50679           PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
50680      &    ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
50681         ELSE
50682           PM0=PYMASS
50683           PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
50684      &    (PM0*PMAS(KC,2)))
50685           PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
50686           PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
50687      &    (PMUPP-PMLOW)*PYR(0))))
50688         ENDIF
50689       ENDIF
50690       MSTJ(93)=0
50691
50692       RETURN
50693       END
50694
50695 C*********************************************************************
50696
50697 C...PYMRUN
50698 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
50699 C...for Higgs couplings. Everything else sent on to PYMASS.
50700
50701       FUNCTION PYMRUN(KF,Q2)
50702
50703 C...Double precision and integer declarations.
50704       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50705       IMPLICIT INTEGER(I-N)
50706       INTEGER PYK,PYCHGE,PYCOMP
50707 C...Commonblocks.
50708       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50709       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50710       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
50711       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
50712
50713 C...Most masses not handled here.
50714       KFA=IABS(KF)
50715       IF(KFA.EQ.0.OR.KFA.GT.6) THEN
50716         PYMRUN=PYMASS(KF)
50717
50718 C...Current-algebra masses, but no Q2 dependence.
50719       ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
50720         PYMRUN=PARF(90+KFA)
50721
50722 C...Running current-algebra masses.
50723       ELSE
50724         AS=PYALPS(Q2)
50725         PYMRUN=PARF(90+KFA)*
50726      &  (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
50727      &  LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
50728       ENDIF
50729
50730       RETURN
50731       END
50732
50733 C*********************************************************************
50734
50735 C...PYNAME
50736 C...Gives the particle/parton name as a character string.
50737
50738       SUBROUTINE PYNAME(KF,CHAU)
50739
50740 C...Double precision and integer declarations.
50741       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50742       IMPLICIT INTEGER(I-N)
50743       INTEGER PYK,PYCHGE,PYCOMP
50744 C...Commonblocks.
50745       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50746       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50747       COMMON/PYDAT4/CHAF(500,2)
50748       CHARACTER CHAF*16
50749       SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
50750 C...Local character variable.
50751       CHARACTER CHAU*16
50752
50753 C...Read out code with distinction particle/antiparticle.
50754       CHAU=' '
50755       KC=PYCOMP(KF)
50756       IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
50757
50758
50759       RETURN
50760       END
50761
50762 C*********************************************************************
50763
50764 C...PYCHGE
50765 C...Gives three times the charge for a particle/parton.
50766
50767       FUNCTION PYCHGE(KF)
50768
50769 C...Double precision and integer declarations.
50770       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50771       IMPLICIT INTEGER(I-N)
50772       INTEGER PYK,PYCHGE,PYCOMP
50773 C...Commonblocks.
50774       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50775       SAVE /PYDAT2/
50776
50777 C...Read out charge and change sign for antiparticle.
50778       PYCHGE=0
50779       KC=PYCOMP(KF)
50780       IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
50781
50782       RETURN
50783       END
50784
50785 C*********************************************************************
50786
50787 C...PYCOMP
50788 C...Compress the standard KF codes for use in mass and decay arrays;
50789 C...also checks whether a given code actually is defined.
50790
50791       FUNCTION PYCOMP(KF)
50792
50793 C...Double precision and integer declarations.
50794       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50795       IMPLICIT INTEGER(I-N)
50796       INTEGER PYK,PYCHGE,PYCOMP
50797 C...Commonblocks.
50798       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50799       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50800       SAVE /PYDAT1/,/PYDAT2/
50801 C...Local arrays and saved data.
50802       DIMENSION KFORD(100:500),KCORD(101:500)
50803       SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
50804
50805 C...Whenever necessary reorder codes for faster search.
50806       IF(MSTU(20).EQ.0) THEN
50807         NFORD=100
50808         KFORD(100)=0
50809         DO 120 I=101,500
50810           KFA=KCHG(I,4)
50811           IF(KFA.LE.100) GOTO 120
50812           NFORD=NFORD+1
50813           DO 100 I1=NFORD-1,0,-1
50814             IF(KFA.GE.KFORD(I1)) GOTO 110
50815             KFORD(I1+1)=KFORD(I1)
50816             KCORD(I1+1)=KCORD(I1)
50817   100     CONTINUE
50818   110     KFORD(I1+1)=KFA
50819           KCORD(I1+1)=I
50820   120   CONTINUE
50821         MSTU(20)=1
50822         KFLAST=0
50823         KCLAST=0
50824       ENDIF
50825
50826 C...Fast action if same code as in latest call.
50827       IF(KF.EQ.KFLAST) THEN
50828         PYCOMP=KCLAST
50829         RETURN
50830       ENDIF
50831
50832 C...Starting values. Remove internal diquark flags.
50833       PYCOMP=0
50834       KFA=IABS(KF)
50835       IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
50836      &     .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
50837
50838 C...Simple cases: direct translation.
50839       IF(KFA.GT.KFORD(NFORD)) THEN
50840       ELSEIF(KFA.LE.100) THEN
50841         PYCOMP=KFA
50842
50843 C...Else binary search.
50844       ELSE
50845         IMIN=100
50846         IMAX=NFORD+1
50847   130   IAVG=(IMIN+IMAX)/2
50848         IF(KFORD(IAVG).GT.KFA) THEN
50849           IMAX=IAVG
50850           IF(IMAX.GT.IMIN+1) GOTO 130
50851         ELSEIF(KFORD(IAVG).LT.KFA) THEN
50852           IMIN=IAVG
50853           IF(IMAX.GT.IMIN+1) GOTO 130
50854         ELSE
50855           PYCOMP=KCORD(IAVG)
50856         ENDIF
50857       ENDIF
50858
50859 C...Check if antiparticle allowed.
50860       IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
50861         IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
50862       ENDIF
50863
50864 C...Save codes for possible future fast action.
50865       KFLAST=KF
50866       KCLAST=PYCOMP
50867
50868       RETURN
50869       END
50870
50871 C*********************************************************************
50872
50873 C...PYERRM
50874 C...Informs user of errors in program execution.
50875
50876       SUBROUTINE PYERRM(MERR,CHMESS)
50877
50878 C...Double precision and integer declarations.
50879       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50880       IMPLICIT INTEGER(I-N)
50881       INTEGER PYK,PYCHGE,PYCOMP
50882 C...Commonblocks.
50883       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50884       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50885       SAVE /PYJETS/,/PYDAT1/
50886 C...Local character variable.
50887       CHARACTER CHMESS*(*)
50888
50889 C...Write first few warnings, then be silent.
50890       IF(MERR.LE.10) THEN
50891         MSTU(27)=MSTU(27)+1
50892         MSTU(28)=MERR
50893         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
50894      &  MERR,MSTU(31),CHMESS
50895
50896 C...Write first few errors, then be silent or stop program.
50897       ELSEIF(MERR.LE.20) THEN
50898         MSTU(23)=MSTU(23)+1
50899         MSTU(24)=MERR-10
50900         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
50901      &  MERR-10,MSTU(31),CHMESS
50902         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
50903           WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
50904           WRITE(MSTU(11),5200)
50905           IF(MERR.NE.17) CALL PYLIST(2)
50906           STOP
50907         ENDIF
50908
50909 C...Stop program in case of irreparable error.
50910       ELSE
50911         WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
50912         STOP
50913       ENDIF
50914
50915 C...Formats for output.
50916  5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
50917      &' PYEXEC calls:'/5X,A)
50918  5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
50919      &' PYEXEC calls:'/5X,A)
50920  5200 FORMAT(5X,'Execution will be stopped after listing of last ',
50921      &'event!')
50922  5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
50923      &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
50924
50925       RETURN
50926       END
50927
50928 C*********************************************************************
50929
50930 C...PYALEM
50931 C...Calculates the running alpha_electromagnetic.
50932
50933       FUNCTION PYALEM(Q2)
50934
50935 C...Double precision and integer declarations.
50936       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50937       IMPLICIT INTEGER(I-N)
50938       INTEGER PYK,PYCHGE,PYCOMP
50939 C...Commonblocks.
50940       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50941       SAVE /PYDAT1/
50942
50943 C...Calculate real part of photon vacuum polarization.
50944 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
50945 C...For hadrons use parametrization of H. Burkhardt et al.
50946 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
50947       AEMPI=PARU(101)/(3D0*PARU(1))
50948       IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
50949         RPIGG=0D0
50950       ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
50951         RPIGG=0D0
50952       ELSEIF(MSTU(101).EQ.2) THEN
50953         RPIGG=1D0-PARU(101)/PARU(103)
50954       ELSEIF(Q2.LT.0.09D0) THEN
50955         RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
50956       ELSEIF(Q2.LT.9D0) THEN
50957         RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
50958      &  0.00238D0*LOG(1D0+3.927D0*Q2)
50959       ELSEIF(Q2.LT.1D4) THEN
50960         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
50961      &  0.00299D0*LOG(1D0+Q2)
50962       ELSE
50963         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
50964      &  0.00293D0*LOG(1D0+Q2)
50965       ENDIF
50966
50967 C...Calculate running alpha_em.
50968       PYALEM=PARU(101)/(1D0-RPIGG)
50969       PARU(108)=PYALEM
50970
50971       RETURN
50972       END
50973
50974 C*********************************************************************
50975
50976 C...PYALPS
50977 C...Gives the value of alpha_strong.
50978
50979       FUNCTION PYALPS(Q2)
50980
50981 C...Double precision and integer declarations.
50982       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50983       IMPLICIT INTEGER(I-N)
50984       INTEGER PYK,PYCHGE,PYCOMP
50985 C...Commonblocks.
50986       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50987       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50988       SAVE /PYDAT1/,/PYDAT2/
50989
50990 C...Constant alpha_strong trivial. Pick artificial Lambda.
50991       IF(MSTU(111).LE.0) THEN
50992         PYALPS=PARU(111)
50993         MSTU(118)=MSTU(112)
50994         PARU(117)=0.2D0
50995         IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
50996      &  ((33D0-2D0*MSTU(112))*PARU(111)))
50997         PARU(118)=PARU(111)
50998         RETURN
50999       ENDIF
51000
51001 C...Find effective Q2, number of flavours and Lambda.
51002       Q2EFF=Q2
51003       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
51004       NF=MSTU(112)
51005       ALAM2=PARU(112)**2
51006   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
51007         Q2THR=PARU(113)*PMAS(NF,1)**2
51008         IF(Q2EFF.LT.Q2THR) THEN
51009           NF=NF-1
51010           ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
51011           GOTO 100
51012         ENDIF
51013       ENDIF
51014   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
51015         Q2THR=PARU(113)*PMAS(NF+1,1)**2
51016         IF(Q2EFF.GT.Q2THR) THEN
51017           NF=NF+1
51018           ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
51019           GOTO 110
51020         ENDIF
51021       ENDIF
51022       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
51023       PARU(117)=SQRT(ALAM2)
51024
51025 C...Evaluate first or second order alpha_strong.
51026       B0=(33D0-2D0*NF)/6D0
51027       ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
51028       IF(MSTU(111).EQ.1) THEN
51029         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
51030       ELSE
51031         B1=(153D0-19D0*NF)/6D0
51032         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
51033      &  (B0**2*ALGQ)))
51034       ENDIF
51035       MSTU(118)=NF
51036       PARU(118)=PYALPS
51037
51038       RETURN
51039       END
51040
51041 C*********************************************************************
51042
51043 C...PYANGL
51044 C...Reconstructs an angle from given x and y coordinates.
51045
51046       FUNCTION PYANGL(X,Y)
51047
51048 C...Double precision and integer declarations.
51049       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51050       IMPLICIT INTEGER(I-N)
51051       INTEGER PYK,PYCHGE,PYCOMP
51052 C...Commonblocks.
51053       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51054       SAVE /PYDAT1/
51055
51056       PYANGL=0D0
51057       R=SQRT(X**2+Y**2)
51058       IF(R.LT.1D-20) RETURN
51059       IF(ABS(X)/R.LT.0.8D0) THEN
51060         PYANGL=SIGN(ACOS(X/R),Y)
51061       ELSE
51062         PYANGL=ASIN(Y/R)
51063         IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
51064           PYANGL=PARU(1)-PYANGL
51065         ELSEIF(X.LT.0D0) THEN
51066           PYANGL=-PARU(1)-PYANGL
51067         ENDIF
51068       ENDIF
51069
51070       RETURN
51071       END
51072
51073 C*********************************************************************
51074
51075 C...PYR
51076 C...Generates random numbers uniformly distributed between
51077 C...0 and 1, excluding the endpoints.
51078
51079 *      FUNCTION PYR(IDUMMY)
51080 *
51081 *C...Double precision and integer declarations.
51082 *      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51083 *      IMPLICIT INTEGER(I-N)
51084 *      INTEGER PYK,PYCHGE,PYCOMP
51085 *C...Commonblocks.
51086 *      COMMON/PYDATR/MRPY(6),RRPY(100)
51087 *      SAVE /PYDATR/
51088 *C...Equivalence between commonblock and local variables.
51089 *      EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
51090 *     &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
51091 *     &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
51092 *
51093 *C...Initialize generation from given seed.
51094 *      IF(MRPY2.EQ.0) THEN
51095 *        IJ=MOD(MRPY1/30082,31329)
51096 *        KL=MOD(MRPY1,30082)
51097 *        I=MOD(IJ/177,177)+2
51098 *        J=MOD(IJ,177)+2
51099 *        K=MOD(KL/169,178)+1
51100 *        L=MOD(KL,169)
51101 *        DO 110 II=1,97
51102 *          S=0D0
51103 *          T=0.5D0
51104 *          DO 100 JJ=1,48
51105 *            M=MOD(MOD(I*J,179)*K,179)
51106 *            I=J
51107 *            J=K
51108 *            K=M
51109 *            L=MOD(53*L+1,169)
51110 *            IF(MOD(L*M,64).GE.32) S=S+T
51111 *            T=0.5D0*T
51112 *  100     CONTINUE
51113 *          RRPY(II)=S
51114 *  110   CONTINUE
51115 *        TWOM24=1D0
51116 *        DO 120 I24=1,24
51117 *          TWOM24=0.5D0*TWOM24
51118 *  120   CONTINUE
51119 *        RRPY98=362436D0*TWOM24
51120 *        RRPY99=7654321D0*TWOM24
51121 *        RRPY00=16777213D0*TWOM24
51122 *        MRPY2=1
51123 *        MRPY3=0
51124 *        MRPY4=97
51125 *        MRPY5=33
51126 *      ENDIF
51127 *
51128 *C...Generate next random number.
51129 *  130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
51130 *      IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51131 *      RRPY(MRPY4)=RUNI
51132 *      MRPY4=MRPY4-1
51133 *      IF(MRPY4.EQ.0) MRPY4=97
51134 *      MRPY5=MRPY5-1
51135 *      IF(MRPY5.EQ.0) MRPY5=97
51136 *      RRPY98=RRPY98-RRPY99
51137 *      IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
51138 *      RUNI=RUNI-RRPY98
51139 *      IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51140 *      IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
51141 *
51142 *C...Update counters. Random number to output.
51143 *      MRPY3=MRPY3+1
51144 *      IF(MRPY3.EQ.1000000000) THEN
51145 *        MRPY2=MRPY2+1
51146 *        MRPY3=0
51147 *      ENDIF
51148 *      PYR=RUNI
51149 *
51150 *      RETURN
51151 *      END
51152 *
51153 C*********************************************************************
51154 *
51155 C...PYRGET
51156 C...Dumps the state of the random number generator on a file
51157 C...for subsequent startup from this state onwards.
51158 *
51159 *      SUBROUTINE PYRGET(LFN,MOVE)
51160 *
51161 C...Double precision and integer declarations.
51162 *      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51163 *      IMPLICIT INTEGER(I-N)
51164 *      INTEGER PYK,PYCHGE,PYCOMP
51165 C...Commonblocks.
51166 *      COMMON/PYDATR/MRPY(6),RRPY(100)
51167 *      SAVE /PYDATR/
51168 C...Local character variable.
51169 *      CHARACTER CHERR*8
51170 *
51171 C...Backspace required number of records (or as many as there are).
51172 *      IF(MOVE.LT.0) THEN
51173 *        NBCK=MIN(MRPY(6),-MOVE)
51174 *        DO 100 IBCK=1,NBCK
51175 *          BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
51176 *  100   CONTINUE
51177 *        MRPY(6)=MRPY(6)-NBCK
51178 *      ENDIF
51179 *
51180 C...Unformatted write on unit LFN.
51181 *      WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51182 *     &(RRPY(I2),I2=1,100)
51183 *      MRPY(6)=MRPY(6)+1
51184 *      RETURN
51185 *
51186 C...Write error.
51187 *  110 WRITE(CHERR,'(I8)') IERR
51188 *      CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
51189 *     &CHERR)
51190 *
51191 *      RETURN
51192 *      END
51193 *
51194 C*********************************************************************
51195
51196 C...PYRSET
51197 C...Reads a state of the random number generator from a file
51198 C...for subsequent generation from this state onwards.
51199 *
51200 *      SUBROUTINE PYRSET(LFN,MOVE)
51201 *
51202 C...Double precision and integer declarations.
51203 *      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51204 *      IMPLICIT INTEGER(I-N)
51205 *      INTEGER PYK,PYCHGE,PYCOMP
51206 C...Commonblocks.
51207 *      COMMON/PYDATR/MRPY(6),RRPY(100)
51208 *      SAVE /PYDATR/
51209 C...Local character variable.
51210 *      CHARACTER CHERR*8
51211 *
51212 C...Backspace required number of records (or as many as there are).
51213 *      IF(MOVE.LT.0) THEN
51214 *        NBCK=MIN(MRPY(6),-MOVE)
51215 *        DO 100 IBCK=1,NBCK
51216 *          BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
51217 *  100   CONTINUE
51218 *        MRPY(6)=MRPY(6)-NBCK
51219 *      ENDIF
51220 *
51221 C...Unformatted read from unit LFN.
51222 *      NFOR=1+MAX(0,MOVE)
51223 *      DO 110 IFOR=1,NFOR
51224 *        READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51225 *     &  (RRPY(I2),I2=1,100)
51226 *  110 CONTINUE
51227 *      MRPY(6)=MRPY(6)+NFOR
51228 *      RETURN
51229 *
51230 C...Write error.
51231 *  120 WRITE(CHERR,'(I8)') IERR
51232 *      CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
51233 *     &CHERR)
51234 *
51235 *      RETURN
51236 *      END
51237 *
51238 C*********************************************************************
51239
51240 C...PYROBO
51241 C...Performs rotations and boosts.
51242
51243       SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
51244
51245 C...Double precision and integer declarations.
51246       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51247       IMPLICIT INTEGER(I-N)
51248       INTEGER PYK,PYCHGE,PYCOMP
51249 C...Commonblocks.
51250       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51251       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51252       SAVE /PYJETS/,/PYDAT1/
51253 C...Local arrays.
51254       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
51255
51256 C...Find and check range of rotation/boost.
51257       IMIN=IMI
51258       IF(IMIN.LE.0) IMIN=1
51259       IF(MSTU(1).GT.0) IMIN=MSTU(1)
51260       IMAX=IMA
51261       IF(IMAX.LE.0) IMAX=N
51262       IF(MSTU(2).GT.0) IMAX=MSTU(2)
51263       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
51264         CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
51265         RETURN
51266       ENDIF
51267
51268 C...Optional resetting of V (when not set before.)
51269       IF(MSTU(33).NE.0) THEN
51270         DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
51271           DO 100 J=1,5
51272             V(I,J)=0D0
51273   100     CONTINUE
51274   110   CONTINUE
51275         MSTU(33)=0
51276       ENDIF
51277
51278 C...Rotate, typically from z axis to direction (theta,phi).
51279       IF(THE**2+PHI**2.GT.1D-20) THEN
51280         ROT(1,1)=COS(THE)*COS(PHI)
51281         ROT(1,2)=-SIN(PHI)
51282         ROT(1,3)=SIN(THE)*COS(PHI)
51283         ROT(2,1)=COS(THE)*SIN(PHI)
51284         ROT(2,2)=COS(PHI)
51285         ROT(2,3)=SIN(THE)*SIN(PHI)
51286         ROT(3,1)=-SIN(THE)
51287         ROT(3,2)=0D0
51288         ROT(3,3)=COS(THE)
51289         DO 140 I=IMIN,IMAX
51290           IF(K(I,1).LE.0) GOTO 140
51291           DO 120 J=1,3
51292             PR(J)=P(I,J)
51293             VR(J)=V(I,J)
51294   120     CONTINUE
51295           DO 130 J=1,3
51296             P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
51297             V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
51298   130     CONTINUE
51299   140   CONTINUE
51300       ENDIF
51301
51302 C...Boost, typically from rest to momentum/energy=beta.
51303       IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
51304         DBX=BEX
51305         DBY=BEY
51306         DBZ=BEZ
51307         DB=SQRT(DBX**2+DBY**2+DBZ**2)
51308         EPS1=1D0-1D-12
51309         IF(DB.GT.EPS1) THEN
51310 C...Rescale boost vector if too close to unity.
51311           CALL PYERRM(3,'(PYROBO:) boost vector too large')
51312           DBX=DBX*(EPS1/DB)
51313           DBY=DBY*(EPS1/DB)
51314           DBZ=DBZ*(EPS1/DB)
51315           DB=EPS1
51316         ENDIF
51317         DGA=1D0/SQRT(1D0-DB**2)
51318         DO 160 I=IMIN,IMAX
51319           IF(K(I,1).LE.0) GOTO 160
51320           DO 150 J=1,4
51321             DP(J)=P(I,J)
51322             DV(J)=V(I,J)
51323   150     CONTINUE
51324           DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
51325           DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
51326           P(I,1)=DP(1)+DGABP*DBX
51327           P(I,2)=DP(2)+DGABP*DBY
51328           P(I,3)=DP(3)+DGABP*DBZ
51329           P(I,4)=DGA*(DP(4)+DBP)
51330           DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
51331           DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
51332           V(I,1)=DV(1)+DGABV*DBX
51333           V(I,2)=DV(2)+DGABV*DBY
51334           V(I,3)=DV(3)+DGABV*DBZ
51335           V(I,4)=DGA*(DV(4)+DBV)
51336   160   CONTINUE
51337       ENDIF
51338
51339       RETURN
51340       END
51341
51342 C*********************************************************************
51343
51344 C...PYEDIT
51345 C...Performs global manipulations on the event record, in particular
51346 C...to exclude unstable or undetectable partons/particles.
51347
51348       SUBROUTINE PYEDIT(MEDIT)
51349
51350 C...Double precision and integer declarations.
51351       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51352       IMPLICIT INTEGER(I-N)
51353       INTEGER PYK,PYCHGE,PYCOMP
51354 C...Commonblocks.
51355       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51356       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51357       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51358       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
51359 C...Local arrays.
51360       DIMENSION NS(2),PTS(2),PLS(2)
51361
51362 C...Remove unwanted partons/particles.
51363       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
51364         IMAX=N
51365         IF(MSTU(2).GT.0) IMAX=MSTU(2)
51366         I1=MAX(1,MSTU(1))-1
51367         DO 110 I=MAX(1,MSTU(1)),IMAX
51368           IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
51369           IF(MEDIT.EQ.1) THEN
51370             IF(K(I,1).GT.10) GOTO 110
51371           ELSEIF(MEDIT.EQ.2) THEN
51372             IF(K(I,1).GT.10) GOTO 110
51373             KC=PYCOMP(K(I,2))
51374             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
51375      &      GOTO 110
51376           ELSEIF(MEDIT.EQ.3) THEN
51377             IF(K(I,1).GT.10) GOTO 110
51378             KC=PYCOMP(K(I,2))
51379             IF(KC.EQ.0) GOTO 110
51380             IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
51381           ELSEIF(MEDIT.EQ.5) THEN
51382             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
51383             KC=PYCOMP(K(I,2))
51384             IF(KC.EQ.0) GOTO 110
51385             IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
51386           ENDIF
51387
51388 C...Pack remaining partons/particles. Origin no longer known.
51389           I1=I1+1
51390           DO 100 J=1,5
51391             K(I1,J)=K(I,J)
51392             P(I1,J)=P(I,J)
51393             V(I1,J)=V(I,J)
51394   100     CONTINUE
51395           K(I1,3)=0
51396   110   CONTINUE
51397         IF(I1.LT.N) MSTU(3)=0
51398         IF(I1.LT.N) MSTU(70)=0
51399         N=I1
51400
51401 C...Selective removal of class of entries. New position of retained.
51402       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
51403         I1=0
51404         DO 120 I=1,N
51405           K(I,3)=MOD(K(I,3),MSTU(5))
51406           IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
51407           IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
51408           IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
51409      &    K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
51410           IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
51411      &    K(I,2).EQ.94)) GOTO 120
51412           IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
51413           I1=I1+1
51414           K(I,3)=K(I,3)+MSTU(5)*I1
51415   120   CONTINUE
51416
51417 C...Find new event history information and replace old.
51418         DO 140 I=1,N
51419           IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
51420      &    GOTO 140
51421           ID=I
51422   130     IM=MOD(K(ID,3),MSTU(5))
51423           IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
51424             IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
51425      &      K(IM,2).NE.94) THEN
51426               ID=IM
51427               GOTO 130
51428             ENDIF
51429           ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
51430             IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
51431               ID=IM
51432               GOTO 130
51433             ENDIF
51434           ENDIF
51435           K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
51436           IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
51437           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
51438             IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
51439      &      K(K(I,4),3)/MSTU(5)
51440             IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
51441      &      K(K(I,5),3)/MSTU(5)
51442           ELSE
51443             KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
51444             IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51445             KCD=MOD(K(I,4),MSTU(5))
51446             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51447             K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51448             KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
51449             IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51450             KCD=MOD(K(I,5),MSTU(5))
51451             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51452             K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51453           ENDIF
51454   140   CONTINUE
51455
51456 C...Pack remaining entries.
51457         I1=0
51458         MSTU90=MSTU(90)
51459         MSTU(90)=0
51460         DO 170 I=1,N
51461           IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
51462           I1=I1+1
51463           DO 150 J=1,5
51464             K(I1,J)=K(I,J)
51465             P(I1,J)=P(I,J)
51466             V(I1,J)=V(I,J)
51467   150     CONTINUE
51468           K(I1,3)=MOD(K(I1,3),MSTU(5))
51469           DO 160 IZ=1,MSTU90
51470             IF(I.EQ.MSTU(90+IZ)) THEN
51471               MSTU(90)=MSTU(90)+1
51472               MSTU(90+MSTU(90))=I1
51473               PARU(90+MSTU(90))=PARU(90+IZ)
51474             ENDIF
51475   160     CONTINUE
51476   170   CONTINUE
51477         IF(I1.LT.N) MSTU(3)=0
51478         IF(I1.LT.N) MSTU(70)=0
51479         N=I1
51480
51481 C...Fill in some missing daughter pointers (lost in colour flow).
51482       ELSEIF(MEDIT.EQ.16) THEN
51483         DO 220 I=1,N
51484           IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
51485           IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
51486 C...Find daughters who point to mother.
51487           DO 180 I1=I+1,N
51488             IF(K(I1,3).NE.I) THEN
51489             ELSEIF(K(I,4).EQ.0) THEN
51490               K(I,4)=I1
51491             ELSE
51492               K(I,5)=I1
51493             ENDIF
51494   180     CONTINUE
51495           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51496           IF(K(I,4).NE.0) GOTO 220
51497 C...Find daughters who point to documentation version of mother.
51498           IM=K(I,3)
51499           IF(IM.LE.0.OR.IM.GE.I) GOTO 220
51500           IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
51501           IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
51502           DO 190 I1=I+1,N
51503             IF(K(I1,3).NE.IM) THEN
51504             ELSEIF(K(I,4).EQ.0) THEN
51505               K(I,4)=I1
51506             ELSE
51507               K(I,5)=I1
51508             ENDIF
51509   190     CONTINUE
51510           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51511           IF(K(I,4).NE.0) GOTO 220
51512 C...Find daughters who point to documentation daughters who,
51513 C...in their turn, point to documentation mother.
51514           ID1=IM
51515           ID2=IM
51516           DO 200 I1=IM+1,I-1
51517             IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
51518               ID2=I1
51519               IF(ID1.EQ.IM) ID1=I1
51520             ENDIF
51521   200     CONTINUE
51522           DO 210 I1=I+1,N
51523             IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
51524             ELSEIF(K(I,4).EQ.0) THEN
51525               K(I,4)=I1
51526             ELSE
51527               K(I,5)=I1
51528             ENDIF
51529   210     CONTINUE
51530           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51531   220   CONTINUE
51532
51533 C...Save top entries at bottom of PYJETS commonblock.
51534       ELSEIF(MEDIT.EQ.21) THEN
51535         IF(2*N.GE.MSTU(4)) THEN
51536           CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
51537           RETURN
51538         ENDIF
51539         DO 240 I=1,N
51540           DO 230 J=1,5
51541             K(MSTU(4)-I,J)=K(I,J)
51542             P(MSTU(4)-I,J)=P(I,J)
51543             V(MSTU(4)-I,J)=V(I,J)
51544   230     CONTINUE
51545   240   CONTINUE
51546         MSTU(32)=N
51547
51548 C...Restore bottom entries of commonblock PYJETS to top.
51549       ELSEIF(MEDIT.EQ.22) THEN
51550         DO 260 I=1,MSTU(32)
51551           DO 250 J=1,5
51552             K(I,J)=K(MSTU(4)-I,J)
51553             P(I,J)=P(MSTU(4)-I,J)
51554             V(I,J)=V(MSTU(4)-I,J)
51555   250     CONTINUE
51556   260   CONTINUE
51557         N=MSTU(32)
51558
51559 C...Mark primary entries at top of commonblock PYJETS as untreated.
51560       ELSEIF(MEDIT.EQ.23) THEN
51561         I1=0
51562         DO 270 I=1,N
51563           KH=K(I,3)
51564           IF(KH.GE.1) THEN
51565             IF(K(KH,1).GT.20) KH=0
51566           ENDIF
51567           IF(KH.NE.0) GOTO 280
51568           I1=I1+1
51569           IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
51570   270   CONTINUE
51571   280   N=I1
51572
51573 C...Place largest axis along z axis and second largest in xy plane.
51574       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
51575         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
51576      &  P(MSTU(61),2)),0D0,0D0,0D0)
51577         CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
51578      &  P(MSTU(61),1)),0D0,0D0,0D0,0D0)
51579         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
51580      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
51581         IF(MEDIT.EQ.31) RETURN
51582
51583 C...Rotate to put slim jet along +z axis.
51584         DO 290 IS=1,2
51585           NS(IS)=0
51586           PTS(IS)=0D0
51587           PLS(IS)=0D0
51588   290   CONTINUE
51589         DO 300 I=1,N
51590           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
51591           IF(MSTU(41).GE.2) THEN
51592             KC=PYCOMP(K(I,2))
51593             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51594      &      KC.EQ.18) GOTO 300
51595             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51596      &      .EQ.0) GOTO 300
51597           ENDIF
51598           IS=2D0-SIGN(0.5D0,P(I,3))
51599           NS(IS)=NS(IS)+1
51600           PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
51601   300   CONTINUE
51602         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
51603      &  CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
51604
51605 C...Rotate to put second largest jet into -z,+x quadrant.
51606         DO 310 I=1,N
51607           IF(P(I,3).GE.0D0) GOTO 310
51608           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
51609           IF(MSTU(41).GE.2) THEN
51610             KC=PYCOMP(K(I,2))
51611             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51612      &      KC.EQ.18) GOTO 310
51613             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51614      &      .EQ.0) GOTO 310
51615           ENDIF
51616           IS=2D0-SIGN(0.5D0,P(I,1))
51617           PLS(IS)=PLS(IS)-P(I,3)
51618   310   CONTINUE
51619         IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
51620      &  0D0,0D0,0D0)
51621       ENDIF
51622
51623       RETURN
51624       END
51625
51626 C*********************************************************************
51627
51628 C...PYLIST
51629 C...Gives program heading, or lists an event, or particle
51630 C...data, or current parameter values.
51631
51632       SUBROUTINE PYLIST(MLIST)
51633
51634 C...Double precision and integer declarations.
51635       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51636       IMPLICIT INTEGER(I-N)
51637       INTEGER PYK,PYCHGE,PYCOMP
51638 C...Parameter statement to help give large particle numbers.
51639       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51640      &KEXCIT=4000000,KDIMEN=5000000)
51641
51642 C...HEPEVT commonblock.
51643       PARAMETER (NMXHEP=4000)
51644       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
51645      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
51646       DOUBLE PRECISION PHEP,VHEP
51647       SAVE /HEPEVT/
51648
51649 C...User process event common block.
51650       INTEGER MAXNUP
51651       PARAMETER (MAXNUP=500)
51652       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
51653       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
51654       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
51655      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
51656      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
51657       SAVE /HEPEUP/
51658
51659 C...Commonblocks.
51660       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51661       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51662       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51663       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
51664       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
51665 C...Local arrays, character variables and data.
51666       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
51667       DIMENSION PS(6)
51668       DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
51669
51670 C...Initialization printout: version number and date of last change.
51671       IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
51672         CALL PYLOGO
51673         MSTU(12)=0
51674         IF(MLIST.EQ.0) RETURN
51675       ENDIF
51676
51677 C...List event data, including additional lines after N.
51678       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
51679         IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
51680         IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
51681         IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
51682         LMX=12
51683         IF(MLIST.GE.2) LMX=16
51684         ISTR=0
51685         IMAX=N
51686         IF(MSTU(2).GT.0) IMAX=MSTU(2)
51687         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
51688           IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
51689           IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
51690           IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
51691
51692 C...Get particle name, pad it and check it is not too long.
51693           CALL PYNAME(K(I,2),CHAP)
51694           LEN=0
51695           DO 100 LEM=1,16
51696             IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
51697   100     CONTINUE
51698           MDL=(K(I,1)+19)/10
51699           LDL=0
51700           IF(MDL.EQ.2.OR.MDL.GE.8) THEN
51701             CHAC=CHAP
51702             IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
51703           ELSE
51704             LDL=1
51705             IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
51706             IF(LEN.EQ.0) THEN
51707               CHAC=CHDL(MDL)(1:2*LDL)//' '
51708             ELSE
51709               CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
51710      &        CHDL(MDL)(LDL+1:2*LDL)//' '
51711               IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
51712             ENDIF
51713           ENDIF
51714
51715 C...Add information on string connection.
51716           IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
51717      &    THEN
51718             KC=PYCOMP(K(I,2))
51719             KCC=0
51720             IF(KC.NE.0) KCC=KCHG(KC,2)
51721             IF(IABS(K(I,2)).EQ.39) THEN
51722               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
51723             ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
51724               ISTR=1
51725               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
51726             ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
51727               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
51728             ELSEIF(KCC.NE.0) THEN
51729               ISTR=0
51730               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
51731             ENDIF
51732           ENDIF
51733
51734 C...Write data for particle/jet.
51735           IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
51736             WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
51737      &      (P(I,J2),J2=1,5)
51738           ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
51739             WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
51740      &      (P(I,J2),J2=1,5)
51741           ELSEIF(MLIST.EQ.1) THEN
51742             WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
51743      &      (P(I,J2),J2=1,5)
51744           ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
51745      &      K(I,1).EQ.14)) THEN
51746             WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
51747      &      K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
51748      &      K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
51749      &      (P(I,J2),J2=1,5)
51750           ELSE
51751             WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
51752      &      (P(I,J2),J2=1,5)
51753           ENDIF
51754           IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
51755
51756 C...Insert extra separator lines specified by user.
51757           IF(MSTU(70).GE.1) THEN
51758             ISEP=0
51759             DO 110 J=1,MIN(10,MSTU(70))
51760               IF(I.EQ.MSTU(70+J)) ISEP=1
51761   110       CONTINUE
51762             IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
51763             IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
51764           ENDIF
51765   120   CONTINUE
51766
51767 C...Sum of charges and momenta.
51768         DO 130 J=1,6
51769           PS(J)=PYP(0,J)
51770   130   CONTINUE
51771         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
51772           WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
51773         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
51774           WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
51775         ELSEIF(MLIST.EQ.1) THEN
51776           WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
51777         ELSE
51778           WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
51779         ENDIF
51780
51781 C...Simple listing of HEPEVT entries (mainly for test purposes).
51782       ELSEIF(MLIST.EQ.5) THEN
51783         WRITE(MSTU(11),7500)
51784         DO 140 I=1,NHEP
51785           IF(ISTHEP(I).EQ.0) GOTO 140
51786           WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
51787      &    JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
51788   140   CONTINUE
51789
51790
51791 C...Simple listing of user-process entries (mainly for test purposes).
51792       ELSEIF(MLIST.EQ.7) THEN
51793         WRITE(MSTU(11),7300)
51794         DO 150 I=1,NUP
51795           WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
51796      &    MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
51797   150   CONTINUE
51798
51799 C...Give simple list of KF codes defined in program.
51800       ELSEIF(MLIST.EQ.11) THEN
51801         WRITE(MSTU(11),6600)
51802         DO 160 KF=1,80
51803           CALL PYNAME(KF,CHAP)
51804           CALL PYNAME(-KF,CHAN)
51805           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51806           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51807   160   CONTINUE
51808         DO 190 KFLS=1,3,2
51809           DO 180 KFLA=1,5
51810             DO 170 KFLB=1,KFLA-(3-KFLS)/2
51811               KF=1000*KFLA+100*KFLB+KFLS
51812               CALL PYNAME(KF,CHAP)
51813               CALL PYNAME(-KF,CHAN)
51814               WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51815   170       CONTINUE
51816   180     CONTINUE
51817   190   CONTINUE
51818         DO 220 KMUL=0,5
51819           KFLS=3
51820           IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
51821           IF(KMUL.EQ.5) KFLS=5
51822           KFLR=0
51823           IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
51824           IF(KMUL.EQ.4) KFLR=2
51825           DO 210 KFLB=1,5
51826             DO 200 KFLC=1,KFLB-1
51827               KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
51828               CALL PYNAME(KF,CHAP)
51829               CALL PYNAME(-KF,CHAN)
51830               WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51831               IF(KF.EQ.311) THEN
51832                 KFK=130
51833                 CALL PYNAME(KFK,CHAP)
51834                 WRITE(MSTU(11),6700) KFK,CHAP
51835                 KFK=310
51836                 CALL PYNAME(KFK,CHAP)
51837                 WRITE(MSTU(11),6700) KFK,CHAP
51838               ENDIF
51839   200       CONTINUE
51840             KF=10000*KFLR+110*KFLB+KFLS
51841             CALL PYNAME(KF,CHAP)
51842             WRITE(MSTU(11),6700) KF,CHAP
51843   210     CONTINUE
51844   220   CONTINUE
51845         KF=100443
51846         CALL PYNAME(KF,CHAP)
51847         WRITE(MSTU(11),6700) KF,CHAP
51848         KF=100553
51849         CALL PYNAME(KF,CHAP)
51850         WRITE(MSTU(11),6700) KF,CHAP
51851         DO 260 KFLSP=1,3
51852           KFLS=2+2*(KFLSP/3)
51853           DO 250 KFLA=1,5
51854             DO 240 KFLB=1,KFLA
51855               DO 230 KFLC=1,KFLB
51856                 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
51857      &          GOTO 230
51858                 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
51859                 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
51860                 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
51861                 CALL PYNAME(KF,CHAP)
51862                 CALL PYNAME(-KF,CHAN)
51863                 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51864   230         CONTINUE
51865   240       CONTINUE
51866   250     CONTINUE
51867   260   CONTINUE
51868         DO 270 KC=1,500
51869           KF=KCHG(KC,4)
51870           IF(KF.LT.1000000) GOTO 270
51871           CALL PYNAME(KF,CHAP)
51872           CALL PYNAME(-KF,CHAN)
51873           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51874           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51875   270   CONTINUE
51876
51877 C...List parton/particle data table. Check whether to be listed.
51878       ELSEIF(MLIST.EQ.12) THEN
51879         WRITE(MSTU(11),6800)
51880         DO 300 KC=1,MSTU(6)
51881           KF=KCHG(KC,4)
51882           IF(KF.EQ.0) GOTO 300
51883           IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
51884      &    GOTO 300
51885
51886 C...Find particle name and mass. Print information.
51887           CALL PYNAME(KF,CHAP)
51888           IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
51889           CALL PYNAME(-KF,CHAN)
51890           WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
51891      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
51892
51893 C...Particle decay: channel number, branching ratios, matrix element,
51894 C...decay products.
51895           DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
51896             DO 280 J=1,5
51897               CALL PYNAME(KFDP(IDC,J),CHAD(J))
51898   280       CONTINUE
51899             WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
51900      &      (CHAD(J),J=1,5)
51901   290     CONTINUE
51902   300   CONTINUE
51903
51904 C...List parameter value table.
51905       ELSEIF(MLIST.EQ.13) THEN
51906         WRITE(MSTU(11),7100)
51907         DO 310 I=1,200
51908           WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
51909   310   CONTINUE
51910       ENDIF
51911
51912 C...Format statements for output on unit MSTU(11) (by default 6).
51913  5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
51914      &5X,'KF  orig    p_x      p_y      p_z       E        m'/)
51915  5200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
51916      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
51917      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
51918  5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
51919      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
51920      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
51921      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
51922  5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
51923  5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
51924  5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
51925  5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
51926  5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
51927  5900 FORMAT(66X,5(1X,F12.3))
51928  6000 FORMAT(1X,78('='))
51929  6100 FORMAT(1X,130('='))
51930  6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
51931  6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
51932  6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
51933  6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
51934      &5F13.5)
51935  6600 FORMAT(///20X,'List of KF codes in program'/)
51936  6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
51937  6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
51938      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
51939      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
51940      &1X,'ME',3X,'Br.rat.',4X,'decay products')
51941  6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
51942      &1X,1P,E13.5,3X,I2)
51943  7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
51944  7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
51945      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
51946  7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
51947  7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
51948      &//'   I IST     ID Mothers   Colours    p_x      p_y      p_z',
51949      &'       E        m')
51950  7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
51951  7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
51952      &//'    I IST    ID   Mothers Daughters    p_x      p_y      p_z',
51953      &'       E        m')
51954  7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
51955
51956       RETURN
51957       END
51958
51959 C*********************************************************************
51960
51961 C...PYLOGO
51962 C...Writes a logo for the program.
51963
51964       SUBROUTINE PYLOGO
51965
51966 C...Double precision and integer declarations.
51967       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51968       IMPLICIT INTEGER(I-N)
51969       INTEGER PYK,PYCHGE,PYCOMP
51970 C...Parameter for length of information block.
51971       PARAMETER (IREFER=18)
51972 C...Commonblocks.
51973       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51974       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51975       SAVE /PYDAT1/,/PYPARS/
51976 C...Local arrays and character variables.
51977       INTEGER IDATI(6)
51978       CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
51979      &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
51980
51981 C...Data on months, logo, titles, and references.
51982       DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
51983      &'Oct','Nov','Dec'/
51984       DATA (LOGO(J),J=1,19)/
51985      &'            *......*            ',
51986      &'       *:::!!:::::::::::*       ',
51987      &'    *::::::!!::::::::::::::*    ',
51988      &'  *::::::::!!::::::::::::::::*  ',
51989      &' *:::::::::!!:::::::::::::::::* ',
51990      &' *:::::::::!!:::::::::::::::::* ',
51991      &'  *::::::::!!::::::::::::::::*! ',
51992      &'    *::::::!!::::::::::::::* !! ',
51993      &'    !! *:::!!:::::::::::*    !! ',
51994      &'    !!     !* -><- *         !! ',
51995      &'    !!     !!                !! ',
51996      &'    !!     !!                !! ',
51997      &'    !!                       !! ',
51998      &'    !!        lh             !! ',
51999      &'    !!                       !! ',
52000      &'    !!                 hh    !! ',
52001      &'    !!    ll                 !! ',
52002      &'    !!                       !! ',
52003      &'    !!                          '/
52004       DATA (LOGO(J),J=20,38)/
52005      &'Welcome to the Lund Monte Carlo!',
52006      &'                                ',
52007      &'PPP  Y   Y TTTTT H   H III   A  ',
52008      &'P  P  Y Y    T   H   H  I   A A ',
52009      &'PPP    Y     T   HHHHH  I  AAAAA',
52010      &'P      Y     T   H   H  I  A   A',
52011      &'P      Y     T   H   H III A   A',
52012      &'                                ',
52013      &'This is PYTHIA version x.xxx    ',
52014      &'Last date of change: xx xxx 199x',
52015      &'                                ',
52016      &'Now is xx xxx 199x at xx:xx:xx  ',
52017      &'                                ',
52018      &'Disclaimer: this program comes  ',
52019      &'without any guarantees. Beware  ',
52020      &'of errors and use common sense  ',
52021      &'when interpreting results.      ',
52022      &'                                ',
52023      &'Copyright T. Sjostrand (2001)   '/
52024       DATA (REFER(J),J=1,18)/
52025      &'An archive of program versions and d',
52026      &'ocumentation is found on the web:   ',
52027      &'http://www.thep.lu.se/~torbjorn/Pyth',
52028      &'ia.html                             ',
52029      &'                                    ',
52030      &'                                    ',
52031      &'When you cite this program, currentl',
52032      &'y the official reference is         ',
52033      &'T. Sjostrand, P. Eden, C. Friberg, L',
52034      &'. Lonnblad, G. Miu, S. Mrenna and   ',
52035      &'E. Norrbin, Computer Physics Commun.',
52036      &' 135 (2001) 238.                    ',
52037      &'The large manual is                 ',
52038      &'                                    ',
52039      &'T. Sjostrand, L. Lonnblad and S. Mre',
52040      &'nna, LU TP 01-21 [hep-ph/0108264].  ',
52041      &'Also remember that the program, to a',
52042      &' large extent, represents original  '/
52043       DATA (REFER(J),J=19,2*IREFER)/
52044      &'physics research. Other publications',
52045      &' of special relevance to your       ',
52046      &'studies may therefore deserve separa',
52047      &'te mention.                         ',
52048      &'                                    ',
52049      &'                                    ',
52050      &'Main author: Torbjorn Sjostrand; Dep',
52051      &'artment of Theoretical Physics 2,   ',
52052      &'  Lund University, Solvegatan 14A, S',
52053      &'-223 62 Lund, Sweden;               ',
52054      &'  phone: + 46 - 46 - 222 48 16; e-ma',
52055      &'il: torbjorn@thep.lu.se             ',
52056      &'SUSY author: Stephen Mrenna, Physics',
52057      &' Department, UC Davis,              ',
52058      &'  One Shields Avenue, Davis, CA 9561',
52059      &'6, USA;                       ',
52060      &'  phone: + 1 - 530 - 752 - 2661; e-m',
52061      &'ail: mrenna@physics.ucdavis.edu     '/
52062
52063 C...Check that PYDATA linked.
52064       IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
52065         WRITE(*,'(1X,A)')
52066      &  'Error: PYDATA has not been linked.'
52067         WRITE(*,'(1X,A)') 'Execution stopped!'
52068         STOP
52069
52070 C...Write current version number and current date+time.
52071       ELSE
52072         WRITE(VERS,'(I1)') MSTP(181)
52073         LOGO(28)(24:24)=VERS
52074         WRITE(SUBV,'(I3)') MSTP(182)
52075         LOGO(28)(26:28)=SUBV
52076         IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
52077         WRITE(DATE,'(I2)') MSTP(185)
52078         LOGO(29)(22:23)=DATE
52079         LOGO(29)(25:27)=MONTH(MSTP(184))
52080         WRITE(YEAR,'(I4)') MSTP(183)
52081         LOGO(29)(29:32)=YEAR
52082         CALL PYTIME(IDATI)
52083         IF(IDATI(1).LE.0) THEN
52084           LOGO(31)='                                '
52085         ELSE
52086           WRITE(DATE,'(I2)') IDATI(3)
52087           LOGO(31)(8:9)=DATE
52088           LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
52089           WRITE(YEAR,'(I4)') IDATI(1)
52090           LOGO(31)(15:18)=YEAR
52091           WRITE(HOUR,'(I2)') IDATI(4)
52092           LOGO(31)(23:24)=HOUR
52093           WRITE(MINU,'(I2)') IDATI(5)
52094           LOGO(31)(26:27)=MINU
52095           IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
52096           WRITE(SECO,'(I2)') IDATI(6)
52097           LOGO(31)(29:30)=SECO
52098           IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
52099         ENDIF
52100       ENDIF
52101
52102 C...Loop over lines in header. Define page feed and side borders.
52103       DO 100 ILIN=1,29+IREFER
52104         LINE=' '
52105         IF(ILIN.EQ.1) THEN
52106           LINE(1:1)='1'
52107         ELSE
52108           LINE(2:3)='**'
52109           LINE(78:79)='**'
52110         ENDIF
52111
52112 C...Separator lines and logos.
52113         IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
52114           LINE(4:77)='***********************************************'//
52115      &    '***************************'
52116         ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
52117           LINE(6:37)=LOGO(ILIN-5)
52118           LINE(44:75)=LOGO(ILIN+14)
52119         ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
52120           LINE(5:40)=REFER(2*ILIN-51)
52121           LINE(41:76)=REFER(2*ILIN-50)
52122         ENDIF
52123
52124 C...Write lines to appropriate unit.
52125         WRITE(MSTU(11),'(A79)') LINE
52126   100 CONTINUE
52127
52128       RETURN
52129       END
52130
52131 C*********************************************************************
52132
52133 C...PYUPDA
52134 C...Facilitates the updating of particle and decay data
52135 C...by allowing it to be done in an external file.
52136
52137       SUBROUTINE PYUPDA(MUPDA,LFN)
52138
52139 C...Double precision and integer declarations.
52140       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52141       IMPLICIT INTEGER(I-N)
52142       INTEGER PYK,PYCHGE,PYCOMP
52143 C...Commonblocks.
52144       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52145       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52146       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52147       COMMON/PYDAT4/CHAF(500,2)
52148       CHARACTER CHAF*16
52149       COMMON/PYINT4/MWID(500),WIDS(500,5)
52150       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
52151 C...Local arrays, character variables and data.
52152       CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
52153      &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
52154       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
52155      &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
52156      &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ',
52157      &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
52158      &'CHAF(I,1)','CHAF(I,2)','MWID(I)  '/
52159
52160 C...Write header if not yet done.
52161       IF(MSTU(12).GE.1) CALL PYLIST(0)
52162
52163 C...Write information on file for editing.
52164       IF(MUPDA.EQ.1) THEN
52165         DO 110 KC=1,500
52166           WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52167      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52168      &    MWID(KC),MDCY(KC,1)
52169           DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52170             WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
52171      &      (KFDP(IDC,J),J=1,5)
52172   100     CONTINUE
52173   110   CONTINUE
52174
52175 C...Read complete set of information from edited file or
52176 C...read partial set of new or updated information from edited file.
52177       ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
52178
52179 C...Reset counters.
52180         KCC=100
52181         NDC=0
52182         CHKF='         '
52183         IF(MUPDA.EQ.2) THEN
52184           DO 120 I=1,MSTU(6)
52185             KCHG(I,4)=0
52186   120     CONTINUE
52187         ELSE
52188           DO 130 KC=1,MSTU(6)
52189             IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
52190             NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
52191   130     CONTINUE
52192         ENDIF
52193
52194 C...Begin of loop: read new line; unknown whether particle or
52195 C...decay data.
52196   140   READ(LFN,5200,END=190) CHINL
52197
52198 C...Identify particle code and whether already defined  (for MUPDA=3).
52199         IF(CHINL(2:10).NE.'         ') THEN
52200           CHKF=CHINL(2:10)
52201           READ(CHKF,5300) KF
52202           IF(MUPDA.EQ.2) THEN
52203             IF(KF.LE.100) THEN
52204               KC=KF
52205             ELSE
52206               KCC=KCC+1
52207               KC=KCC
52208             ENDIF
52209           ELSE
52210             KCREP=0
52211             IF(KF.LE.100) THEN
52212               KCREP=KF
52213             ELSE
52214               DO 150 KCR=101,KCC
52215                 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
52216   150         CONTINUE
52217             ENDIF
52218 C...Remove duplicate old decay data.
52219             IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
52220               IDCREP=MDCY(KCREP,2)
52221               NDCREP=MDCY(KCREP,3)
52222               DO 160 I=1,KCC
52223                 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
52224   160         CONTINUE
52225               DO 180 I=IDCREP,NDC-NDCREP
52226                 MDME(I,1)=MDME(I+NDCREP,1)
52227                 MDME(I,2)=MDME(I+NDCREP,2)
52228                 BRAT(I)=BRAT(I+NDCREP)
52229                 DO 170 J=1,5
52230                   KFDP(I,J)=KFDP(I+NDCREP,J)
52231   170           CONTINUE
52232   180         CONTINUE
52233               NDC=NDC-NDCREP
52234               KC=KCREP
52235             ELSEIF(KCREP.NE.0) THEN
52236               KC=KCREP
52237             ELSE
52238               KCC=KCC+1
52239               KC=KCC
52240             ENDIF
52241           ENDIF
52242
52243 C...Study line with particle data.
52244           IF(KC.GT.MSTU(6)) CALL PYERRM(27,
52245      &    '(PYUPDA:) Particle arrays full by KF ='//CHKF)
52246           READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52247      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52248      &    MWID(KC),MDCY(KC,1)
52249           MDCY(KC,2)=0
52250           MDCY(KC,3)=0
52251
52252 C...Study line with decay data.
52253         ELSE
52254           NDC=NDC+1
52255           IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
52256      &    '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
52257           IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
52258           MDCY(KC,3)=MDCY(KC,3)+1
52259           READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
52260      &    (KFDP(NDC,J),J=1,5)
52261         ENDIF
52262
52263 C...End of loop; ensure that PYCOMP tables are updated.
52264         GOTO 140
52265   190   CONTINUE
52266         MSTU(20)=0
52267
52268 C...Perform possible tests that new information is consistent.
52269         DO 220 KC=1,MSTU(6)
52270           KF=KCHG(KC,4)
52271           IF(KF.EQ.0) GOTO 220
52272           WRITE(CHKF,5300) KF
52273           IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
52274      &    PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
52275      &    '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
52276           BRSUM=0D0
52277           DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52278             IF(MDME(IDC,2).GT.80) GOTO 210
52279             KQ=KCHG(KC,1)
52280             PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
52281             MERR=0
52282             DO 200 J=1,5
52283               KP=KFDP(IDC,J)
52284               IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
52285                 IF(KP.EQ.81) KQ=0
52286               ELSEIF(PYCOMP(KP).EQ.0) THEN
52287                 MERR=3
52288               ELSE
52289                 KQ=KQ-PYCHGE(KP)
52290                 KPC=PYCOMP(KP)
52291                 PMS=PMS-PMAS(KPC,1)
52292                 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
52293      &          PMAS(KPC,3))
52294               ENDIF
52295   200       CONTINUE
52296             IF(KQ.NE.0) MERR=MAX(2,MERR)
52297             IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
52298      &      MERR=MAX(1,MERR)
52299             IF(MERR.EQ.3) CALL PYERRM(17,
52300      &      '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
52301             IF(MERR.EQ.2) CALL PYERRM(17,
52302      &      '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
52303             IF(MERR.EQ.1) CALL PYERRM(7,
52304      &      '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
52305             BRSUM=BRSUM+BRAT(IDC)
52306   210     CONTINUE
52307           WRITE(CHTMP,5500) BRSUM
52308           IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
52309      &    CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
52310      &    CHTMP(9:16)//' for KF ='//CHKF)
52311   220   CONTINUE
52312
52313 C...Write DATA statements for inclusion in program.
52314       ELSEIF(MUPDA.EQ.4) THEN
52315
52316 C...Find out how many codes and decay channels are actually used.
52317         KCC=0
52318         NDC=0
52319         DO 230 I=1,MSTU(6)
52320           IF(KCHG(I,4).NE.0) THEN
52321             KCC=I
52322             NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
52323           ENDIF
52324   230   CONTINUE
52325
52326 C...Initialize writing of DATA statements for inclusion in program.
52327         DO 300 IVAR=1,22
52328           NDIM=MSTU(6)
52329           IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
52330           NLIN=1
52331           CHLIN=' '
52332           CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
52333           LLIN=35
52334           CHOLD='START'
52335
52336 C...Loop through variables for conversion to characters.
52337           DO 280 IDIM=1,NDIM
52338             IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
52339             IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
52340             IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
52341             IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
52342             IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
52343             IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
52344             IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
52345             IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
52346             IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
52347             IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
52348             IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
52349             IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
52350             IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
52351             IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
52352             IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
52353             IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
52354             IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
52355             IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
52356             IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
52357             IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
52358             IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
52359             IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
52360
52361 C...Replace variables beyond what is properly defined.
52362             IF(IVAR.LE.4) THEN
52363               IF(IDIM.GT.KCC) CHTMP='               0'
52364             ELSEIF(IVAR.LE.8) THEN
52365               IF(IDIM.GT.KCC) CHTMP='             0.0'
52366             ELSEIF(IVAR.LE.11) THEN
52367               IF(IDIM.GT.KCC) CHTMP='               0'
52368             ELSEIF(IVAR.LE.13) THEN
52369               IF(IDIM.GT.NDC) CHTMP='               0'
52370             ELSEIF(IVAR.LE.14) THEN
52371               IF(IDIM.GT.NDC) CHTMP='             0.0'
52372             ELSEIF(IVAR.LE.19) THEN
52373               IF(IDIM.GT.NDC) CHTMP='               0'
52374             ELSEIF(IVAR.LE.21) THEN
52375               IF(IDIM.GT.KCC) CHTMP='                '
52376             ELSE
52377               IF(IDIM.GT.KCC) CHTMP='               0'
52378             ENDIF
52379
52380 C...Length of variable, trailing decimal zeros, quotation marks.
52381             LLOW=1
52382             LHIG=1
52383             DO 240 LL=1,16
52384               IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
52385               IF(CHTMP(LL:LL).NE.' ') LHIG=LL
52386   240       CONTINUE
52387             CHNEW=CHTMP(LLOW:LHIG)//' '
52388             LNEW=1+LHIG-LLOW
52389             IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
52390               LNEW=LNEW+1
52391   250         LNEW=LNEW-1
52392               IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
52393               IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
52394               IF(LNEW.EQ.0) THEN
52395                 CHNEW(1:3)='0D0'
52396                 LNEW=3
52397               ELSE
52398                 CHNEW(LNEW+1:LNEW+2)='D0'
52399                 LNEW=LNEW+2
52400               ENDIF
52401             ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
52402               DO 260 LL=LNEW,1,-1
52403                 IF(CHNEW(LL:LL).EQ.'''') THEN
52404                   CHTMP=CHNEW
52405                   CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
52406                   LNEW=LNEW+1
52407                 ENDIF
52408   260         CONTINUE
52409               LNEW=MIN(14,LNEW)
52410               CHTMP=CHNEW
52411               CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
52412               LNEW=LNEW+2
52413             ENDIF
52414
52415 C...Form composite character string, often including repetition counter.
52416             IF(CHNEW.NE.CHOLD) THEN
52417               NRPT=1
52418               CHOLD=CHNEW
52419               CHCOM=CHNEW
52420               LCOM=LNEW
52421             ELSE
52422               LRPT=LNEW+1
52423               IF(NRPT.GE.2) LRPT=LNEW+3
52424               IF(NRPT.GE.10) LRPT=LNEW+4
52425               IF(NRPT.GE.100) LRPT=LNEW+5
52426               IF(NRPT.GE.1000) LRPT=LNEW+6
52427               LLIN=LLIN-LRPT
52428               NRPT=NRPT+1
52429               WRITE(CHTMP,5400) NRPT
52430               LRPT=1
52431               IF(NRPT.GE.10) LRPT=2
52432               IF(NRPT.GE.100) LRPT=3
52433               IF(NRPT.GE.1000) LRPT=4
52434               CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
52435               LCOM=LRPT+1+LNEW
52436             ENDIF
52437
52438 C...Add characters to end of line, to new line (after storing old line),
52439 C...or to new block of lines (after writing old block).
52440             IF(LLIN+LCOM.LE.70) THEN
52441               CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
52442               LLIN=LLIN+LCOM+1
52443             ELSEIF(NLIN.LE.19) THEN
52444               CHLIN(LLIN+1:72)=' '
52445               CHBLK(NLIN)=CHLIN
52446               NLIN=NLIN+1
52447               CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
52448               LLIN=6+LCOM+1
52449             ELSE
52450               CHLIN(LLIN:72)='/'//' '
52451               CHBLK(NLIN)=CHLIN
52452               WRITE(CHTMP,5400) IDIM-NRPT
52453               CHBLK(1)(30:33)=CHTMP(13:16)
52454               DO 270 ILIN=1,NLIN
52455                 WRITE(LFN,5700) CHBLK(ILIN)
52456   270         CONTINUE
52457               NLIN=1
52458               CHLIN=' '
52459               CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
52460      &        ',I=    ,    )/'//CHCOM(1:LCOM)//','
52461               WRITE(CHTMP,5400) IDIM-NRPT+1
52462               CHLIN(25:28)=CHTMP(13:16)
52463               LLIN=35+LCOM+1
52464             ENDIF
52465   280     CONTINUE
52466
52467 C...Write final block of lines.
52468           CHLIN(LLIN:72)='/'//' '
52469           CHBLK(NLIN)=CHLIN
52470           WRITE(CHTMP,5400) NDIM
52471           CHBLK(1)(30:33)=CHTMP(13:16)
52472           DO 290 ILIN=1,NLIN
52473             WRITE(LFN,5700) CHBLK(ILIN)
52474   290     CONTINUE
52475   300   CONTINUE
52476       ENDIF
52477
52478 C...Formats for reading and writing particle data.
52479  5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
52480  5100 FORMAT(10X,2I5,F12.6,5I10)
52481  5200 FORMAT(A120)
52482  5300 FORMAT(I9)
52483  5400 FORMAT(I16)
52484  5500 FORMAT(F16.5)
52485  5600 FORMAT(F16.6)
52486  5700 FORMAT(A72)
52487
52488       RETURN
52489       END
52490
52491 C*********************************************************************
52492
52493 C...PYK
52494 C...Provides various integer-valued event related data.
52495
52496       FUNCTION PYK(I,J)
52497
52498 C...Double precision and integer declarations.
52499       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52500       IMPLICIT INTEGER(I-N)
52501       INTEGER PYK,PYCHGE,PYCOMP
52502 C...Commonblocks.
52503       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52504       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52505       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52506       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52507
52508 C...Default value. For I=0 number of entries, number of stable entries
52509 C...or 3 times total charge.
52510       PYK=0
52511       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52512       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
52513         PYK=N
52514       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
52515         DO 100 I1=1,N
52516           IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
52517           IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
52518      &    PYCHGE(K(I1,2))
52519   100   CONTINUE
52520       ELSEIF(I.EQ.0) THEN
52521
52522 C...For I > 0 direct readout of K matrix or charge.
52523       ELSEIF(J.LE.5) THEN
52524         PYK=K(I,J)
52525       ELSEIF(J.EQ.6) THEN
52526         PYK=PYCHGE(K(I,2))
52527
52528 C...Status (existing/fragmented/decayed), parton/hadron separation.
52529       ELSEIF(J.LE.8) THEN
52530         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
52531         IF(J.EQ.8) PYK=PYK*K(I,2)
52532       ELSEIF(J.LE.12) THEN
52533         KFA=IABS(K(I,2))
52534         KC=PYCOMP(KFA)
52535         KQ=0
52536         IF(KC.NE.0) KQ=KCHG(KC,2)
52537         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
52538         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
52539         IF(J.EQ.11) PYK=KC
52540         IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
52541
52542 C...Heaviest flavour in hadron/diquark.
52543       ELSEIF(J.EQ.13) THEN
52544         KFA=IABS(K(I,2))
52545         PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
52546         IF(KFA.LT.10) PYK=KFA
52547         IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
52548         PYK=PYK*ISIGN(1,K(I,2))
52549
52550 C...Particle history: generation, ancestor, rank.
52551       ELSEIF(J.LE.15) THEN
52552         I2=I
52553         I1=I
52554   110   PYK=PYK+1
52555         I2=I1
52556         I1=K(I1,3)
52557         IF(I1.GT.0) THEN
52558           IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
52559         ENDIF
52560         IF(J.EQ.15) PYK=I2
52561       ELSEIF(J.EQ.16) THEN
52562         KFA=IABS(K(I,2))
52563         IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
52564      &  (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
52565           I1=I
52566   120     I2=I1
52567           I1=K(I1,3)
52568           IF(I1.GT.0) THEN
52569             KFAM=IABS(K(I1,2))
52570             ILP=1
52571             IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
52572             IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
52573      &      ILP=0
52574             IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
52575             IF(ILP.EQ.1) GOTO 120
52576           ENDIF
52577           IF(K(I1,1).EQ.12) THEN
52578             DO 130 I3=I1+1,I2
52579               IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
52580      &        .AND.K(I3,2).NE.93) PYK=PYK+1
52581   130       CONTINUE
52582           ELSE
52583             I3=I2
52584   140       PYK=PYK+1
52585             I3=I3+1
52586             IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
52587           ENDIF
52588         ENDIF
52589
52590 C...Particle coming from collapsing jet system or not.
52591       ELSEIF(J.EQ.17) THEN
52592         I1=I
52593   150   PYK=PYK+1
52594         I3=I1
52595         I1=K(I1,3)
52596         I0=MAX(1,I1)
52597         KC=PYCOMP(K(I0,2))
52598         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
52599           IF(PYK.EQ.1) PYK=-1
52600           IF(PYK.GT.1) PYK=0
52601           RETURN
52602         ENDIF
52603         IF(KCHG(KC,2).EQ.0) GOTO 150
52604         IF(K(I1,1).NE.12) PYK=0
52605         IF(K(I1,1).NE.12) RETURN
52606         I2=I1
52607   160   I2=I2+1
52608         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
52609         K3M=K(I3-1,3)
52610         IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
52611         K3P=K(I3+1,3)
52612         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
52613
52614 C...Number of decay products. Colour flow.
52615       ELSEIF(J.EQ.18) THEN
52616         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
52617         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
52618       ELSEIF(J.LE.22) THEN
52619         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
52620         IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
52621         IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
52622         IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
52623         IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
52624       ELSE
52625       ENDIF
52626
52627       RETURN
52628       END
52629
52630 C*********************************************************************
52631
52632 C...PYP
52633 C...Provides various real-valued event related data.
52634
52635       FUNCTION PYP(I,J)
52636
52637 C...Double precision and integer declarations.
52638       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52639       IMPLICIT INTEGER(I-N)
52640       INTEGER PYK,PYCHGE,PYCOMP
52641 C...Commonblocks.
52642       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52643       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52644       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52645       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52646 C...Local array.
52647       DIMENSION PSUM(4)
52648
52649 C...Set default value. For I = 0 sum of momenta or charges,
52650 C...or invariant mass of system.
52651       PYP=0D0
52652       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52653       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
52654         DO 100 I1=1,N
52655           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
52656   100   CONTINUE
52657       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
52658         DO 120 J1=1,4
52659           PSUM(J1)=0D0
52660           DO 110 I1=1,N
52661             IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
52662      &      P(I1,J1)
52663   110     CONTINUE
52664   120   CONTINUE
52665         PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
52666       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
52667         DO 130 I1=1,N
52668           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
52669   130   CONTINUE
52670       ELSEIF(I.EQ.0) THEN
52671
52672 C...Direct readout of P matrix.
52673       ELSEIF(J.LE.5) THEN
52674         PYP=P(I,J)
52675
52676 C...Charge, total momentum, transverse momentum, transverse mass.
52677       ELSEIF(J.LE.12) THEN
52678         IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
52679         IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
52680         IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
52681         IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
52682         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
52683
52684 C...Theta and phi angle in radians or degrees.
52685       ELSEIF(J.LE.16) THEN
52686         IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
52687         IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
52688         IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
52689
52690 C...True rapidity, rapidity with pion mass, pseudorapidity.
52691       ELSEIF(J.LE.19) THEN
52692         PMR=0D0
52693         IF(J.EQ.17) PMR=P(I,5)
52694         IF(J.EQ.18) PMR=PYMASS(211)
52695         PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
52696         PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
52697      &  1D20)),P(I,3))
52698
52699 C...Energy and momentum fractions (only to be used in CM frame).
52700       ELSEIF(J.LE.25) THEN
52701         IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
52702         IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
52703         IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
52704         IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
52705         IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
52706         IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
52707       ENDIF
52708
52709       RETURN
52710       END
52711
52712 C*********************************************************************
52713
52714 C...PYSPHE
52715 C...Performs sphericity tensor analysis to give sphericity,
52716 C...aplanarity and the related event axes.
52717
52718       SUBROUTINE PYSPHE(SPH,APL)
52719
52720 C...Double precision and integer declarations.
52721       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52722       IMPLICIT INTEGER(I-N)
52723       INTEGER PYK,PYCHGE,PYCOMP
52724 C...Commonblocks.
52725       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52726       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52727       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52728       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52729 C...Local arrays.
52730       DIMENSION SM(3,3),SV(3,3)
52731
52732 C...Calculate matrix to be diagonalized.
52733       NP=0
52734       DO 110 J1=1,3
52735         DO 100 J2=J1,3
52736           SM(J1,J2)=0D0
52737   100   CONTINUE
52738   110 CONTINUE
52739       PS=0D0
52740       DO 140 I=1,N
52741         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
52742         IF(MSTU(41).GE.2) THEN
52743           KC=PYCOMP(K(I,2))
52744           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52745      &    KC.EQ.18) GOTO 140
52746           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52747      &    GOTO 140
52748         ENDIF
52749         NP=NP+1
52750         PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52751         PWT=1D0
52752         IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
52753      &  MAX(1D-10,PA)**(PARU(41)-2D0)
52754         DO 130 J1=1,3
52755           DO 120 J2=J1,3
52756             SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
52757   120     CONTINUE
52758   130   CONTINUE
52759         PS=PS+PWT*PA**2
52760   140 CONTINUE
52761
52762 C...Very low multiplicities (0 or 1) not considered.
52763       IF(NP.LE.1) THEN
52764         CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
52765         SPH=-1D0
52766         APL=-1D0
52767         RETURN
52768       ENDIF
52769       DO 160 J1=1,3
52770         DO 150 J2=J1,3
52771           SM(J1,J2)=SM(J1,J2)/PS
52772   150   CONTINUE
52773   160 CONTINUE
52774
52775 C...Find eigenvalues to matrix (third degree equation).
52776       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
52777      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
52778       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
52779      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
52780      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
52781       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
52782       P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
52783       P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
52784       P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
52785       IF(P(N+2,4).LT.1D-5) THEN
52786         CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
52787         SPH=-1D0
52788         APL=-1D0
52789         RETURN
52790       ENDIF
52791
52792 C...Find first and last eigenvector by solving equation system.
52793       DO 240 I=1,3,2
52794         DO 180 J1=1,3
52795           SV(J1,J1)=SM(J1,J1)-P(N+I,4)
52796           DO 170 J2=J1+1,3
52797             SV(J1,J2)=SM(J1,J2)
52798             SV(J2,J1)=SM(J1,J2)
52799   170     CONTINUE
52800   180   CONTINUE
52801         SMAX=0D0
52802         DO 200 J1=1,3
52803           DO 190 J2=1,3
52804             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
52805             JA=J1
52806             JB=J2
52807             SMAX=ABS(SV(J1,J2))
52808   190     CONTINUE
52809   200   CONTINUE
52810         SMAX=0D0
52811         DO 220 J3=JA+1,JA+2
52812           J1=J3-3*((J3-1)/3)
52813           RL=SV(J1,JB)/SV(JA,JB)
52814           DO 210 J2=1,3
52815             SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
52816             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
52817             JC=J1
52818             SMAX=ABS(SV(J1,J2))
52819   210     CONTINUE
52820   220   CONTINUE
52821         JB1=JB+1-3*(JB/3)
52822         JB2=JB+2-3*((JB+1)/3)
52823         P(N+I,JB1)=-SV(JC,JB2)
52824         P(N+I,JB2)=SV(JC,JB1)
52825         P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
52826      &  SV(JA,JB)
52827         PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
52828         SGN=(-1D0)**INT(PYR(0)+0.5D0)
52829         DO 230 J=1,3
52830           P(N+I,J)=SGN*P(N+I,J)/PA
52831   230   CONTINUE
52832   240 CONTINUE
52833
52834 C...Middle axis orthogonal to other two. Fill other codes.
52835       SGN=(-1D0)**INT(PYR(0)+0.5D0)
52836       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
52837       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
52838       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
52839       DO 260 I=1,3
52840         K(N+I,1)=31
52841         K(N+I,2)=95
52842         K(N+I,3)=I
52843         K(N+I,4)=0
52844         K(N+I,5)=0
52845         P(N+I,5)=0D0
52846         DO 250 J=1,5
52847           V(I,J)=0D0
52848   250   CONTINUE
52849   260 CONTINUE
52850
52851 C...Calculate sphericity and aplanarity. Select storing option.
52852       SPH=1.5D0*(P(N+2,4)+P(N+3,4))
52853       APL=1.5D0*P(N+3,4)
52854       MSTU(61)=N+1
52855       MSTU(62)=NP
52856       IF(MSTU(43).LE.1) MSTU(3)=3
52857       IF(MSTU(43).GE.2) N=N+3
52858
52859       RETURN
52860       END
52861
52862 C*********************************************************************
52863
52864 C...PYTHRU
52865 C...Performs thrust analysis to give thrust, oblateness
52866 C...and the related event axes.
52867
52868       SUBROUTINE PYTHRU(THR,OBL)
52869
52870 C...Double precision and integer declarations.
52871       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52872       IMPLICIT INTEGER(I-N)
52873       INTEGER PYK,PYCHGE,PYCOMP
52874 C...Commonblocks.
52875       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52876       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52877       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52878       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52879 C...Local arrays.
52880       DIMENSION TDI(3),TPR(3)
52881
52882 C...Take copy of particles that are to be considered in thrust analysis.
52883       NP=0
52884       PS=0D0
52885       DO 100 I=1,N
52886         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
52887         IF(MSTU(41).GE.2) THEN
52888           KC=PYCOMP(K(I,2))
52889           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52890      &    KC.EQ.18) GOTO 100
52891           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52892      &    GOTO 100
52893         ENDIF
52894         IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
52895           CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
52896           THR=-2D0
52897           OBL=-2D0
52898           RETURN
52899         ENDIF
52900         NP=NP+1
52901         K(N+NP,1)=23
52902         P(N+NP,1)=P(I,1)
52903         P(N+NP,2)=P(I,2)
52904         P(N+NP,3)=P(I,3)
52905         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52906         P(N+NP,5)=1D0
52907         IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
52908      &  P(N+NP,4)**(PARU(42)-1D0)
52909         PS=PS+P(N+NP,4)*P(N+NP,5)
52910   100 CONTINUE
52911
52912 C...Very low multiplicities (0 or 1) not considered.
52913       IF(NP.LE.1) THEN
52914         CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
52915         THR=-1D0
52916         OBL=-1D0
52917         RETURN
52918       ENDIF
52919
52920 C...Loop over thrust and major. T axis along z direction in latter case.
52921       DO 320 ILD=1,2
52922         IF(ILD.EQ.2) THEN
52923           K(N+NP+1,1)=31
52924           PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
52925           MSTU(33)=1
52926           CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
52927           THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
52928           CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
52929         ENDIF
52930
52931 C...Find and order particles with highest p (pT for major).
52932         DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
52933           P(ILF,4)=0D0
52934   110   CONTINUE
52935         DO 160 I=N+1,N+NP
52936           IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
52937           DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
52938             IF(P(I,4).LE.P(ILF,4)) GOTO 140
52939             DO 120 J=1,5
52940               P(ILF+1,J)=P(ILF,J)
52941   120       CONTINUE
52942   130     CONTINUE
52943           ILF=N+NP+3
52944   140     DO 150 J=1,5
52945             P(ILF+1,J)=P(I,J)
52946   150     CONTINUE
52947   160   CONTINUE
52948
52949 C...Find and order initial axes with highest thrust (major).
52950         DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
52951           P(ILG,4)=0D0
52952   170   CONTINUE
52953         NC=2**(MIN(MSTU(44),NP)-1)
52954         DO 250 ILC=1,NC
52955           DO 180 J=1,3
52956             TDI(J)=0D0
52957   180     CONTINUE
52958           DO 200 ILF=1,MIN(MSTU(44),NP)
52959             SGN=P(N+NP+ILF+3,5)
52960             IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
52961             DO 190 J=1,4-ILD
52962               TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
52963   190       CONTINUE
52964   200     CONTINUE
52965           TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
52966           DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
52967             IF(TDS.LE.P(ILG,4)) GOTO 230
52968             DO 210 J=1,4
52969               P(ILG+1,J)=P(ILG,J)
52970   210       CONTINUE
52971   220     CONTINUE
52972           ILG=N+NP+MSTU(44)+4
52973   230     DO 240 J=1,3
52974             P(ILG+1,J)=TDI(J)
52975   240     CONTINUE
52976           P(ILG+1,4)=TDS
52977   250   CONTINUE
52978
52979 C...Iterate direction of axis until stable maximum.
52980         P(N+NP+ILD,4)=0D0
52981         ILG=0
52982   260   ILG=ILG+1
52983         THP=0D0
52984   270   THPS=THP
52985         DO 280 J=1,3
52986           IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
52987           IF(THP.GT.1D-10) TDI(J)=TPR(J)
52988           TPR(J)=0D0
52989   280   CONTINUE
52990         DO 300 I=N+1,N+NP
52991           SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
52992           DO 290 J=1,4-ILD
52993             TPR(J)=TPR(J)+SGN*P(I,J)
52994   290     CONTINUE
52995   300   CONTINUE
52996         THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
52997         IF(THP.GE.THPS+PARU(48)) GOTO 270
52998
52999 C...Save good axis. Try new initial axis until a number of tries agree.
53000         IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
53001         IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
53002           IAGR=0
53003           SGN=(-1D0)**INT(PYR(0)+0.5D0)
53004           DO 310 J=1,3
53005             P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
53006   310     CONTINUE
53007           P(N+NP+ILD,4)=THP
53008           P(N+NP+ILD,5)=0D0
53009         ENDIF
53010         IAGR=IAGR+1
53011         IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
53012   320 CONTINUE
53013
53014 C...Find minor axis and value by orthogonality.
53015       SGN=(-1D0)**INT(PYR(0)+0.5D0)
53016       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
53017       P(N+NP+3,2)=SGN*P(N+NP+2,1)
53018       P(N+NP+3,3)=0D0
53019       THP=0D0
53020       DO 330 I=N+1,N+NP
53021         THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
53022   330 CONTINUE
53023       P(N+NP+3,4)=THP/PS
53024       P(N+NP+3,5)=0D0
53025
53026 C...Fill axis information. Rotate back to original coordinate system.
53027       DO 350 ILD=1,3
53028         K(N+ILD,1)=31
53029         K(N+ILD,2)=96
53030         K(N+ILD,3)=ILD
53031         K(N+ILD,4)=0
53032         K(N+ILD,5)=0
53033         DO 340 J=1,5
53034           P(N+ILD,J)=P(N+NP+ILD,J)
53035           V(N+ILD,J)=0D0
53036   340   CONTINUE
53037   350 CONTINUE
53038       CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
53039
53040 C...Calculate thrust and oblateness. Select storing option.
53041       THR=P(N+1,4)
53042       OBL=P(N+2,4)-P(N+3,4)
53043       MSTU(61)=N+1
53044       MSTU(62)=NP
53045       IF(MSTU(43).LE.1) MSTU(3)=3
53046       IF(MSTU(43).GE.2) N=N+3
53047
53048       RETURN
53049       END
53050
53051 C*********************************************************************
53052
53053 C...PYCLUS
53054 C...Subdivides the particle content of an event into jets/clusters.
53055
53056       SUBROUTINE PYCLUS(NJET)
53057
53058 C...Double precision and integer declarations.
53059       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53060       IMPLICIT INTEGER(I-N)
53061       INTEGER PYK,PYCHGE,PYCOMP
53062 C...Commonblocks.
53063       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53064       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53065       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53066       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53067 C...Local arrays and saved variables.
53068       DIMENSION PS(5)
53069       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
53070
53071 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
53072       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
53073      &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
53074       R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
53075      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53076       R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
53077      &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53078
53079 C...If first time, reset. If reentering, skip preliminaries.
53080       IF(MSTU(48).LE.0) THEN
53081         NP=0
53082         DO 100 J=1,5
53083           PS(J)=0D0
53084   100   CONTINUE
53085         PSS=0D0
53086         PIMASS=PMAS(PYCOMP(211),1)
53087       ELSE
53088         NJET=NSAV
53089         IF(MSTU(43).GE.2) N=N-NJET
53090         DO 110 I=N+1,N+NJET
53091           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53092   110   CONTINUE
53093         IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53094           R2ACC=PARU(44)**2
53095         ELSE
53096           R2ACC=PARU(45)*PS(5)**2
53097         ENDIF
53098         NLOOP=0
53099         GOTO 300
53100       ENDIF
53101
53102 C...Find which particles are to be considered in cluster search.
53103       DO 140 I=1,N
53104         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
53105         IF(MSTU(41).GE.2) THEN
53106           KC=PYCOMP(K(I,2))
53107           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53108      &    KC.EQ.18) GOTO 140
53109           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53110      &    GOTO 140
53111         ENDIF
53112         IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
53113           CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
53114           NJET=-1
53115           RETURN
53116         ENDIF
53117
53118 C...Take copy of these particles, with space left for jets later on.
53119         NP=NP+1
53120         K(N+NP,3)=I
53121         DO 120 J=1,5
53122           P(N+NP,J)=P(I,J)
53123   120   CONTINUE
53124         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53125         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53126         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53127         P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53128         DO 130 J=1,4
53129           PS(J)=PS(J)+P(N+NP,J)
53130   130   CONTINUE
53131         PSS=PSS+P(N+NP,5)
53132   140 CONTINUE
53133       DO 160 I=N+1,N+NP
53134         K(I+NP,3)=K(I,3)
53135         DO 150 J=1,5
53136           P(I+NP,J)=P(I,J)
53137   150   CONTINUE
53138   160 CONTINUE
53139       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
53140
53141 C...Very low multiplicities not considered.
53142       IF(NP.LT.MSTU(47)) THEN
53143         CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
53144         NJET=-1
53145         RETURN
53146       ENDIF
53147
53148 C...Find precluster configuration. If too few jets, make harder cuts.
53149       NLOOP=0
53150       IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53151         R2ACC=PARU(44)**2
53152       ELSE
53153         R2ACC=PARU(45)*PS(5)**2
53154       ENDIF
53155       RINIT=1.25D0*PARU(43)
53156       IF(NP.LE.MSTU(47)+2) RINIT=0D0
53157   170 RINIT=0.8D0*RINIT
53158       NPRE=0
53159       NREM=NP
53160       DO 180 I=N+NP+1,N+2*NP
53161         K(I,4)=0
53162   180 CONTINUE
53163
53164 C...Sum up small momentum region. Jet if enough absolute momentum.
53165       IF(MSTU(46).LE.2) THEN
53166         DO 190 J=1,4
53167           P(N+1,J)=0D0
53168   190   CONTINUE
53169         DO 210 I=N+NP+1,N+2*NP
53170           IF(P(I,5).GT.2D0*RINIT) GOTO 210
53171           NREM=NREM-1
53172           K(I,4)=1
53173           DO 200 J=1,4
53174             P(N+1,J)=P(N+1,J)+P(I,J)
53175   200     CONTINUE
53176   210   CONTINUE
53177         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
53178         IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
53179         IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53180         IF(NREM.EQ.0) GOTO 170
53181       ENDIF
53182
53183 C...Find fastest remaining particle.
53184   220 NPRE=NPRE+1
53185       PMAX=0D0
53186       DO 230 I=N+NP+1,N+2*NP
53187         IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
53188         IMAX=I
53189         PMAX=P(I,5)
53190   230 CONTINUE
53191       DO 240 J=1,5
53192         P(N+NPRE,J)=P(IMAX,J)
53193   240 CONTINUE
53194       NREM=NREM-1
53195       K(IMAX,4)=NPRE
53196
53197 C...Sum up precluster around it according to pT separation.
53198       IF(MSTU(46).LE.2) THEN
53199         DO 260 I=N+NP+1,N+2*NP
53200           IF(K(I,4).NE.0) GOTO 260
53201           R2=R2T(I,IMAX)
53202           IF(R2.GT.RINIT**2) GOTO 260
53203           NREM=NREM-1
53204           K(I,4)=NPRE
53205           DO 250 J=1,4
53206             P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
53207   250     CONTINUE
53208   260   CONTINUE
53209         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53210
53211 C...Sum up precluster around it according to mass or
53212 C...Durham pT separation.
53213       ELSE
53214   270   IMIN=0
53215         R2MIN=RINIT**2
53216         DO 280 I=N+NP+1,N+2*NP
53217           IF(K(I,4).NE.0) GOTO 280
53218           IF(MSTU(46).LE.4) THEN
53219             R2=R2M(I,N+NPRE)
53220           ELSE
53221             R2=R2D(I,N+NPRE)
53222           ENDIF
53223           IF(R2.GE.R2MIN) GOTO 280
53224           IMIN=I
53225           R2MIN=R2
53226   280   CONTINUE
53227         IF(IMIN.NE.0) THEN
53228           DO 290 J=1,4
53229             P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
53230   290     CONTINUE
53231           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53232           NREM=NREM-1
53233           K(IMIN,4)=NPRE
53234           GOTO 270
53235         ENDIF
53236       ENDIF
53237
53238 C...Check if more preclusters to be found. Start over if too few.
53239       IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53240       IF(NREM.GT.0) GOTO 220
53241       NJET=NPRE
53242
53243 C...Reassign all particles to nearest jet. Sum up new jet momenta.
53244   300 TSAV=0D0
53245       PSJT=0D0
53246   310 IF(MSTU(46).LE.1) THEN
53247         DO 330 I=N+1,N+NJET
53248           DO 320 J=1,4
53249             V(I,J)=0D0
53250   320     CONTINUE
53251   330   CONTINUE
53252         DO 360 I=N+NP+1,N+2*NP
53253           R2MIN=PSS**2
53254           DO 340 IJET=N+1,N+NJET
53255             IF(P(IJET,5).LT.RINIT) GOTO 340
53256             R2=R2T(I,IJET)
53257             IF(R2.GE.R2MIN) GOTO 340
53258             IMIN=IJET
53259             R2MIN=R2
53260   340     CONTINUE
53261           K(I,4)=IMIN-N
53262           DO 350 J=1,4
53263             V(IMIN,J)=V(IMIN,J)+P(I,J)
53264   350     CONTINUE
53265   360   CONTINUE
53266         PSJT=0D0
53267         DO 380 I=N+1,N+NJET
53268           DO 370 J=1,4
53269             P(I,J)=V(I,J)
53270   370     CONTINUE
53271           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53272           PSJT=PSJT+P(I,5)
53273   380   CONTINUE
53274       ENDIF
53275
53276 C...Find two closest jets.
53277       R2MIN=2D0*MAX(R2ACC,PS(5)**2)
53278       DO 400 ITRY1=N+1,N+NJET-1
53279         DO 390 ITRY2=ITRY1+1,N+NJET
53280           IF(MSTU(46).LE.2) THEN
53281             R2=R2T(ITRY1,ITRY2)
53282           ELSEIF(MSTU(46).LE.4) THEN
53283             R2=R2M(ITRY1,ITRY2)
53284           ELSE
53285             R2=R2D(ITRY1,ITRY2)
53286           ENDIF
53287           IF(R2.GE.R2MIN) GOTO 390
53288           IMIN1=ITRY1
53289           IMIN2=ITRY2
53290           R2MIN=R2
53291   390   CONTINUE
53292   400 CONTINUE
53293
53294 C...If allowed, join two closest jets and start over.
53295       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
53296         IREC=MIN(IMIN1,IMIN2)
53297         IDEL=MAX(IMIN1,IMIN2)
53298         DO 410 J=1,4
53299           P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
53300   410   CONTINUE
53301         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
53302         DO 430 I=IDEL+1,N+NJET
53303           DO 420 J=1,5
53304             P(I-1,J)=P(I,J)
53305   420     CONTINUE
53306   430   CONTINUE
53307         IF(MSTU(46).GE.2) THEN
53308           DO 440 I=N+NP+1,N+2*NP
53309             IORI=N+K(I,4)
53310             IF(IORI.EQ.IDEL) K(I,4)=IREC-N
53311             IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
53312   440     CONTINUE
53313         ENDIF
53314         NJET=NJET-1
53315         GOTO 300
53316
53317 C...Divide up broad jet if empty cluster in list of final ones.
53318       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
53319         DO 450 I=N+1,N+NJET
53320           K(I,5)=0
53321   450   CONTINUE
53322         DO 460 I=N+NP+1,N+2*NP
53323           K(N+K(I,4),5)=K(N+K(I,4),5)+1
53324   460   CONTINUE
53325         IEMP=0
53326         DO 470 I=N+1,N+NJET
53327           IF(K(I,5).EQ.0) IEMP=I
53328   470   CONTINUE
53329         IF(IEMP.NE.0) THEN
53330           NLOOP=NLOOP+1
53331           ISPL=0
53332           R2MAX=0D0
53333           DO 480 I=N+NP+1,N+2*NP
53334             IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
53335             IJET=N+K(I,4)
53336             R2=R2T(I,IJET)
53337             IF(R2.LE.R2MAX) GOTO 480
53338             ISPL=I
53339             R2MAX=R2
53340   480     CONTINUE
53341           IF(ISPL.NE.0) THEN
53342             IJET=N+K(ISPL,4)
53343             DO 490 J=1,4
53344               P(IEMP,J)=P(ISPL,J)
53345               P(IJET,J)=P(IJET,J)-P(ISPL,J)
53346   490       CONTINUE
53347             P(IEMP,5)=P(ISPL,5)
53348             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
53349             IF(NLOOP.LE.2) GOTO 300
53350           ENDIF
53351         ENDIF
53352       ENDIF
53353
53354 C...If generalized thrust has not yet converged, continue iteration.
53355       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
53356      &THEN
53357         TSAV=PSJT/PSS
53358         GOTO 310
53359       ENDIF
53360
53361 C...Reorder jets according to energy.
53362       DO 510 I=N+1,N+NJET
53363         DO 500 J=1,5
53364           V(I,J)=P(I,J)
53365   500   CONTINUE
53366   510 CONTINUE
53367       DO 540 INEW=N+1,N+NJET
53368         PEMAX=0D0
53369         DO 520 ITRY=N+1,N+NJET
53370           IF(V(ITRY,4).LE.PEMAX) GOTO 520
53371           IMAX=ITRY
53372           PEMAX=V(ITRY,4)
53373   520   CONTINUE
53374         K(INEW,1)=31
53375         K(INEW,2)=97
53376         K(INEW,3)=INEW-N
53377         K(INEW,4)=0
53378         DO 530 J=1,5
53379           P(INEW,J)=V(IMAX,J)
53380   530   CONTINUE
53381         V(IMAX,4)=-1D0
53382         K(IMAX,5)=INEW
53383   540 CONTINUE
53384
53385 C...Clean up particle-jet assignments and jet information.
53386       DO 550 I=N+NP+1,N+2*NP
53387         IORI=K(N+K(I,4),5)
53388         K(I,4)=IORI-N
53389         IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
53390         K(IORI,4)=K(IORI,4)+1
53391   550 CONTINUE
53392       IEMP=0
53393       PSJT=0D0
53394       DO 570 I=N+1,N+NJET
53395         K(I,5)=0
53396         PSJT=PSJT+P(I,5)
53397         P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
53398         DO 560 J=1,5
53399           V(I,J)=0D0
53400   560   CONTINUE
53401         IF(K(I,4).EQ.0) IEMP=I
53402   570 CONTINUE
53403
53404 C...Select storing option. Output variables. Check for failure.
53405       MSTU(61)=N+1
53406       MSTU(62)=NP
53407       MSTU(63)=NPRE
53408       PARU(61)=PS(5)
53409       PARU(62)=PSJT/PSS
53410       PARU(63)=SQRT(R2MIN)
53411       IF(NJET.LE.1) PARU(63)=0D0
53412       IF(IEMP.NE.0) THEN
53413         CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
53414         NJET=-1
53415         RETURN
53416       ENDIF
53417       IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53418       IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53419       NSAV=NJET
53420
53421       RETURN
53422       END
53423
53424 C*********************************************************************
53425
53426 C...PYCELL
53427 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
53428 C...as used for calorimeters at hadron colliders.
53429
53430       SUBROUTINE PYCELL(NJET)
53431
53432 C...Double precision and integer declarations.
53433       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53434       IMPLICIT INTEGER(I-N)
53435       INTEGER PYK,PYCHGE,PYCOMP
53436 C...Commonblocks.
53437       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53438       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53439       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53440       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53441
53442 C...Loop over all particles. Find cell that was hit by given particle.
53443       PTLRAT=1D0/SINH(PARU(51))**2
53444       NP=0
53445       NC=N
53446       DO 110 I=1,N
53447         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53448         IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
53449         IF(MSTU(41).GE.2) THEN
53450           KC=PYCOMP(K(I,2))
53451           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53452      &    KC.EQ.18) GOTO 110
53453           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53454      &    GOTO 110
53455         ENDIF
53456         NP=NP+1
53457         PT=SQRT(P(I,1)**2+P(I,2)**2)
53458         ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
53459         IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
53460      &  (ETA/PARU(51)+1D0))))
53461         PHI=PYANGL(P(I,1),P(I,2))
53462         IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
53463      &  (PHI/PARU(1)+1D0))))
53464         IETPH=MSTU(52)*IETA+IPHI
53465
53466 C...Add to cell already hit, or book new cell.
53467         DO 100 IC=N+1,NC
53468           IF(IETPH.EQ.K(IC,3)) THEN
53469             K(IC,4)=K(IC,4)+1
53470             P(IC,5)=P(IC,5)+PT
53471             GOTO 110
53472           ENDIF
53473   100   CONTINUE
53474         IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
53475           CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53476           NJET=-2
53477           RETURN
53478         ENDIF
53479         NC=NC+1
53480         K(NC,3)=IETPH
53481         K(NC,4)=1
53482         K(NC,5)=2
53483         P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
53484         P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
53485         P(NC,5)=PT
53486   110 CONTINUE
53487
53488 C...Smear true bin content by calorimeter resolution.
53489       IF(MSTU(53).GE.1) THEN
53490         DO 130 IC=N+1,NC
53491           PEI=P(IC,5)
53492           IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
53493   120     PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
53494      &    COS(PARU(2)*PYR(0))
53495           IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
53496           P(IC,5)=PEF
53497           IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
53498   130   CONTINUE
53499       ENDIF
53500
53501 C...Remove cells below threshold.
53502       IF(PARU(58).GT.0D0) THEN
53503         NCC=NC
53504         NC=N
53505         DO 140 IC=N+1,NCC
53506           IF(P(IC,5).GT.PARU(58)) THEN
53507             NC=NC+1
53508             K(NC,3)=K(IC,3)
53509             K(NC,4)=K(IC,4)
53510             K(NC,5)=K(IC,5)
53511             P(NC,1)=P(IC,1)
53512             P(NC,2)=P(IC,2)
53513             P(NC,5)=P(IC,5)
53514           ENDIF
53515   140   CONTINUE
53516       ENDIF
53517
53518 C...Find initiator cell: the one with highest pT of not yet used ones.
53519       NJ=NC
53520   150 ETMAX=0D0
53521       DO 160 IC=N+1,NC
53522         IF(K(IC,5).NE.2) GOTO 160
53523         IF(P(IC,5).LE.ETMAX) GOTO 160
53524         ICMAX=IC
53525         ETA=P(IC,1)
53526         PHI=P(IC,2)
53527         ETMAX=P(IC,5)
53528   160 CONTINUE
53529       IF(ETMAX.LT.PARU(52)) GOTO 220
53530       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
53531         CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53532         NJET=-2
53533         RETURN
53534       ENDIF
53535       K(ICMAX,5)=1
53536       NJ=NJ+1
53537       K(NJ,4)=0
53538       K(NJ,5)=1
53539       P(NJ,1)=ETA
53540       P(NJ,2)=PHI
53541       P(NJ,3)=0D0
53542       P(NJ,4)=0D0
53543       P(NJ,5)=0D0
53544
53545 C...Sum up unused cells within required distance of initiator.
53546       DO 170 IC=N+1,NC
53547         IF(K(IC,5).EQ.0) GOTO 170
53548         IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
53549         DPHIA=ABS(P(IC,2)-PHI)
53550         IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
53551         PHIC=P(IC,2)
53552         IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
53553         IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
53554         K(IC,5)=-K(IC,5)
53555         K(NJ,4)=K(NJ,4)+K(IC,4)
53556         P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
53557         P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
53558         P(NJ,5)=P(NJ,5)+P(IC,5)
53559   170 CONTINUE
53560
53561 C...Reject cluster below minimum ET, else accept.
53562       IF(P(NJ,5).LT.PARU(53)) THEN
53563         NJ=NJ-1
53564         DO 180 IC=N+1,NC
53565           IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
53566   180   CONTINUE
53567       ELSEIF(MSTU(54).LE.2) THEN
53568         P(NJ,3)=P(NJ,3)/P(NJ,5)
53569         P(NJ,4)=P(NJ,4)/P(NJ,5)
53570         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
53571      &  P(NJ,4))
53572         DO 190 IC=N+1,NC
53573           IF(K(IC,5).LT.0) K(IC,5)=0
53574   190   CONTINUE
53575       ELSE
53576         DO 200 J=1,4
53577           P(NJ,J)=0D0
53578   200   CONTINUE
53579         DO 210 IC=N+1,NC
53580           IF(K(IC,5).GE.0) GOTO 210
53581           P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
53582           P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
53583           P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
53584           P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
53585           K(IC,5)=0
53586   210   CONTINUE
53587       ENDIF
53588       GOTO 150
53589
53590 C...Arrange clusters in falling ET sequence.
53591   220 DO 250 I=1,NJ-NC
53592         ETMAX=0D0
53593         DO 230 IJ=NC+1,NJ
53594           IF(K(IJ,5).EQ.0) GOTO 230
53595           IF(P(IJ,5).LT.ETMAX) GOTO 230
53596           IJMAX=IJ
53597           ETMAX=P(IJ,5)
53598   230   CONTINUE
53599         K(IJMAX,5)=0
53600         K(N+I,1)=31
53601         K(N+I,2)=98
53602         K(N+I,3)=I
53603         K(N+I,4)=K(IJMAX,4)
53604         K(N+I,5)=0
53605         DO 240 J=1,5
53606           P(N+I,J)=P(IJMAX,J)
53607           V(N+I,J)=0D0
53608   240   CONTINUE
53609   250 CONTINUE
53610       NJET=NJ-NC
53611
53612 C...Convert to massless or massive four-vectors.
53613       IF(MSTU(54).EQ.2) THEN
53614         DO 260 I=N+1,N+NJET
53615           ETA=P(I,3)
53616           P(I,1)=P(I,5)*COS(P(I,4))
53617           P(I,2)=P(I,5)*SIN(P(I,4))
53618           P(I,3)=P(I,5)*SINH(ETA)
53619           P(I,4)=P(I,5)*COSH(ETA)
53620           P(I,5)=0D0
53621   260   CONTINUE
53622       ELSEIF(MSTU(54).GE.3) THEN
53623         DO 270 I=N+1,N+NJET
53624           P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
53625   270   CONTINUE
53626       ENDIF
53627
53628 C...Information about storage.
53629       MSTU(61)=N+1
53630       MSTU(62)=NP
53631       MSTU(63)=NC-N
53632       IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53633       IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53634
53635       RETURN
53636       END
53637
53638 C*********************************************************************
53639
53640 C...PYJMAS
53641 C...Determines, approximately, the two jet masses that minimize
53642 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
53643
53644       SUBROUTINE PYJMAS(PMH,PML)
53645
53646 C...Double precision and integer declarations.
53647       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53648       IMPLICIT INTEGER(I-N)
53649       INTEGER PYK,PYCHGE,PYCOMP
53650 C...Commonblocks.
53651       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53652       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53653       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53654       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53655 C...Local arrays.
53656       DIMENSION SM(3,3),SAX(3),PS(3,5)
53657
53658 C...Reset.
53659       NP=0
53660       DO 120 J1=1,3
53661         DO 100 J2=J1,3
53662           SM(J1,J2)=0D0
53663   100   CONTINUE
53664         DO 110 J2=1,4
53665           PS(J1,J2)=0D0
53666   110   CONTINUE
53667   120 CONTINUE
53668       PSS=0D0
53669       PIMASS=PMAS(PYCOMP(211),1)
53670
53671 C...Take copy of particles that are to be considered in mass analysis.
53672       DO 170 I=1,N
53673         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
53674         IF(MSTU(41).GE.2) THEN
53675           KC=PYCOMP(K(I,2))
53676           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53677      &    KC.EQ.18) GOTO 170
53678           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53679      &    GOTO 170
53680         ENDIF
53681         IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
53682           CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
53683           PMH=-2D0
53684           PML=-2D0
53685           RETURN
53686         ENDIF
53687         NP=NP+1
53688         DO 130 J=1,5
53689           P(N+NP,J)=P(I,J)
53690   130   CONTINUE
53691         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53692         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53693         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53694
53695 C...Fill information in sphericity tensor and total momentum vector.
53696         DO 150 J1=1,3
53697           DO 140 J2=J1,3
53698             SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
53699   140     CONTINUE
53700   150   CONTINUE
53701         PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53702         DO 160 J=1,4
53703           PS(3,J)=PS(3,J)+P(N+NP,J)
53704   160   CONTINUE
53705   170 CONTINUE
53706
53707 C...Very low multiplicities (0 or 1) not considered.
53708       IF(NP.LE.1) THEN
53709         CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
53710         PMH=-1D0
53711         PML=-1D0
53712         RETURN
53713       ENDIF
53714       PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
53715      &PS(3,3)**2))
53716
53717 C...Find largest eigenvalue to matrix (third degree equation).
53718       DO 190 J1=1,3
53719         DO 180 J2=J1,3
53720           SM(J1,J2)=SM(J1,J2)/PSS
53721   180   CONTINUE
53722   190 CONTINUE
53723       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
53724      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
53725       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
53726      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
53727      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
53728       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
53729       SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
53730
53731 C...Find largest eigenvector by solving equation system.
53732       DO 210 J1=1,3
53733         SM(J1,J1)=SM(J1,J1)-SMA
53734         DO 200 J2=J1+1,3
53735           SM(J2,J1)=SM(J1,J2)
53736   200   CONTINUE
53737   210 CONTINUE
53738       SMAX=0D0
53739       DO 230 J1=1,3
53740         DO 220 J2=1,3
53741           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
53742           JA=J1
53743           JB=J2
53744           SMAX=ABS(SM(J1,J2))
53745   220   CONTINUE
53746   230 CONTINUE
53747       SMAX=0D0
53748       DO 250 J3=JA+1,JA+2
53749         J1=J3-3*((J3-1)/3)
53750         RL=SM(J1,JB)/SM(JA,JB)
53751         DO 240 J2=1,3
53752           SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
53753           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
53754           JC=J1
53755           SMAX=ABS(SM(J1,J2))
53756   240   CONTINUE
53757   250 CONTINUE
53758       JB1=JB+1-3*(JB/3)
53759       JB2=JB+2-3*((JB+1)/3)
53760       SAX(JB1)=-SM(JC,JB2)
53761       SAX(JB2)=SM(JC,JB1)
53762       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
53763
53764 C...Divide particles into two initial clusters by hemisphere.
53765       DO 270 I=N+1,N+NP
53766         PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
53767         IS=1
53768         IF(PSAX.LT.0D0) IS=2
53769         K(I,3)=IS
53770         DO 260 J=1,4
53771           PS(IS,J)=PS(IS,J)+P(I,J)
53772   260   CONTINUE
53773   270 CONTINUE
53774       PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
53775      &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
53776
53777 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
53778   280 PMD=0D0
53779       IM=0
53780       DO 290 J=1,4
53781         PS(3,J)=PS(1,J)-PS(2,J)
53782   290 CONTINUE
53783       DO 300 I=N+1,N+NP
53784         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)
53785         IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
53786         IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
53787         IF(PMDI.LT.PMD) THEN
53788           PMD=PMDI
53789           IM=I
53790         ENDIF
53791   300 CONTINUE
53792
53793 C...Loop back if significant reduction in sum of m^2.
53794       IF(PMD.LT.-PARU(48)*PMS) THEN
53795         PMS=PMS+PMD
53796         IS=K(IM,3)
53797         DO 310 J=1,4
53798           PS(IS,J)=PS(IS,J)-P(IM,J)
53799           PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
53800   310   CONTINUE
53801         K(IM,3)=3-IS
53802         GOTO 280
53803       ENDIF
53804
53805 C...Final masses and output.
53806       MSTU(61)=N+1
53807       MSTU(62)=NP
53808       PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
53809       PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
53810       PMH=MAX(PS(1,5),PS(2,5))
53811       PML=MIN(PS(1,5),PS(2,5))
53812
53813       RETURN
53814       END
53815
53816 C*********************************************************************
53817
53818 C...PYFOWO
53819 C...Calculates the first few Fox-Wolfram moments.
53820
53821       SUBROUTINE PYFOWO(H10,H20,H30,H40)
53822
53823 C...Double precision and integer declarations.
53824       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53825       IMPLICIT INTEGER(I-N)
53826       INTEGER PYK,PYCHGE,PYCOMP
53827 C...Commonblocks.
53828       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53829       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53830       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53831       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53832
53833 C...Copy momenta for particles and calculate H0.
53834       NP=0
53835       H0=0D0
53836       HD=0D0
53837       DO 110 I=1,N
53838         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53839         IF(MSTU(41).GE.2) THEN
53840           KC=PYCOMP(K(I,2))
53841           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53842      &    KC.EQ.18) GOTO 110
53843           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53844      &    GOTO 110
53845         ENDIF
53846         IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
53847           CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
53848           H10=-1D0
53849           H20=-1D0
53850           H30=-1D0
53851           H40=-1D0
53852           RETURN
53853         ENDIF
53854         NP=NP+1
53855         DO 100 J=1,3
53856           P(N+NP,J)=P(I,J)
53857   100   CONTINUE
53858         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53859         H0=H0+P(N+NP,4)
53860         HD=HD+P(N+NP,4)**2
53861   110 CONTINUE
53862       H0=H0**2
53863
53864 C...Very low multiplicities (0 or 1) not considered.
53865       IF(NP.LE.1) THEN
53866         CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
53867         H10=-1D0
53868         H20=-1D0
53869         H30=-1D0
53870         H40=-1D0
53871         RETURN
53872       ENDIF
53873
53874 C...Calculate H1 - H4.
53875       H10=0D0
53876       H20=0D0
53877       H30=0D0
53878       H40=0D0
53879       DO 130 I1=N+1,N+NP
53880         DO 120 I2=I1+1,N+NP
53881           CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
53882      &    (P(I1,4)*P(I2,4))
53883           H10=H10+P(I1,4)*P(I2,4)*CTHE
53884           H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
53885           H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
53886           H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
53887      &    0.375D0)
53888   120   CONTINUE
53889   130 CONTINUE
53890
53891 C...Calculate H1/H0 - H4/H0. Output.
53892       MSTU(61)=N+1
53893       MSTU(62)=NP
53894       H10=(HD+2D0*H10)/H0
53895       H20=(HD+2D0*H20)/H0
53896       H30=(HD+2D0*H30)/H0
53897       H40=(HD+2D0*H40)/H0
53898
53899       RETURN
53900       END
53901
53902 C*********************************************************************
53903
53904 C...PYTABU
53905 C...Evaluates various properties of an event, with statistics
53906 C...accumulated during the course of the run and
53907 C...printed at the end.
53908
53909       SUBROUTINE PYTABU(MTABU)
53910
53911 C...Double precision and integer declarations.
53912       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53913       IMPLICIT INTEGER(I-N)
53914       INTEGER PYK,PYCHGE,PYCOMP
53915 C...Commonblocks.
53916       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53917       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53918       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53919       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53920       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
53921 C...Local arrays, character variables, saved variables and data.
53922       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
53923      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
53924      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
53925      &KFDM(8),KFDC(200,0:8),NPDC(200)
53926       SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
53927      &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
53928      &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
53929       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
53930       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
53931      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
53932      &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
53933      &NEVDC/0/,NKFDC/0/,NREDC/0/
53934
53935 C...Reset statistics on initial parton state.
53936       IF(MTABU.EQ.10) THEN
53937         NEVIS=0
53938         NKFIS=0
53939
53940 C...Identify and order flavour content of initial state.
53941       ELSEIF(MTABU.EQ.11) THEN
53942         NEVIS=NEVIS+1
53943         KFM1=2*IABS(MSTU(161))
53944         IF(MSTU(161).GT.0) KFM1=KFM1-1
53945         KFM2=2*IABS(MSTU(162))
53946         IF(MSTU(162).GT.0) KFM2=KFM2-1
53947         KFMN=MIN(KFM1,KFM2)
53948         KFMX=MAX(KFM1,KFM2)
53949         DO 100 I=1,NKFIS
53950           IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
53951             IKFIS=-I
53952             GOTO 110
53953           ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
53954      &      KFMX.LT.KFIS(I,2))) THEN
53955             IKFIS=I
53956             GOTO 110
53957           ENDIF
53958   100   CONTINUE
53959         IKFIS=NKFIS+1
53960   110   IF(IKFIS.LT.0) THEN
53961           IKFIS=-IKFIS
53962         ELSE
53963           IF(NKFIS.GE.100) RETURN
53964           DO 130 I=NKFIS,IKFIS,-1
53965             KFIS(I+1,1)=KFIS(I,1)
53966             KFIS(I+1,2)=KFIS(I,2)
53967             DO 120 J=0,10
53968               NPIS(I+1,J)=NPIS(I,J)
53969   120       CONTINUE
53970   130     CONTINUE
53971           NKFIS=NKFIS+1
53972           KFIS(IKFIS,1)=KFMN
53973           KFIS(IKFIS,2)=KFMX
53974           DO 140 J=0,10
53975             NPIS(IKFIS,J)=0
53976   140     CONTINUE
53977         ENDIF
53978         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
53979
53980 C...Count number of partons in initial state.
53981         NP=0
53982         DO 160 I=1,N
53983           IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
53984           ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
53985           ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
53986      &      THEN
53987           ELSE
53988             IM=I
53989   150       IM=K(IM,3)
53990             IF(IM.LE.0.OR.IM.GT.N) THEN
53991               NP=NP+1
53992             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
53993               NP=NP+1
53994             ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
53995             ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
53996      &        .NE.0) THEN
53997             ELSE
53998               GOTO 150
53999             ENDIF
54000           ENDIF
54001   160   CONTINUE
54002         NPCO=MAX(NP,1)
54003         IF(NP.GE.6) NPCO=6
54004         IF(NP.GE.8) NPCO=7
54005         IF(NP.GE.11) NPCO=8
54006         IF(NP.GE.16) NPCO=9
54007         IF(NP.GE.26) NPCO=10
54008         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
54009         MSTU(62)=NP
54010
54011 C...Write statistics on initial parton state.
54012       ELSEIF(MTABU.EQ.12) THEN
54013         FAC=1D0/MAX(1,NEVIS)
54014         WRITE(MSTU(11),5000) NEVIS
54015         DO 170 I=1,NKFIS
54016           KFMN=KFIS(I,1)
54017           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54018           KFM1=(KFMN+1)/2
54019           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54020           CALL PYNAME(KFM1,CHAU)
54021           CHIS(1)=CHAU(1:12)
54022           IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
54023           KFMX=KFIS(I,2)
54024           IF(KFIS(I,1).EQ.0) KFMX=0
54025           KFM2=(KFMX+1)/2
54026           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54027           CALL PYNAME(KFM2,CHAU)
54028           CHIS(2)=CHAU(1:12)
54029           IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
54030           WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
54031      &    (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
54032   170   CONTINUE
54033
54034 C...Copy statistics on initial parton state into /PYJETS/.
54035       ELSEIF(MTABU.EQ.13) THEN
54036         FAC=1D0/MAX(1,NEVIS)
54037         DO 190 I=1,NKFIS
54038           KFMN=KFIS(I,1)
54039           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54040           KFM1=(KFMN+1)/2
54041           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54042           KFMX=KFIS(I,2)
54043           IF(KFIS(I,1).EQ.0) KFMX=0
54044           KFM2=(KFMX+1)/2
54045           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54046           K(I,1)=32
54047           K(I,2)=99
54048           K(I,3)=KFM1
54049           K(I,4)=KFM2
54050           K(I,5)=NPIS(I,0)
54051           DO 180 J=1,5
54052             P(I,J)=FAC*NPIS(I,J)
54053             V(I,J)=FAC*NPIS(I,J+5)
54054   180     CONTINUE
54055   190   CONTINUE
54056         N=NKFIS
54057         DO 200 J=1,5
54058           K(N+1,J)=0
54059           P(N+1,J)=0D0
54060           V(N+1,J)=0D0
54061   200   CONTINUE
54062         K(N+1,1)=32
54063         K(N+1,2)=99
54064         K(N+1,5)=NEVIS
54065         MSTU(3)=1
54066
54067 C...Reset statistics on number of particles/partons.
54068       ELSEIF(MTABU.EQ.20) THEN
54069         NEVFS=0
54070         NPRFS=0
54071         NFIFS=0
54072         NCHFS=0
54073         NKFFS=0
54074
54075 C...Identify whether particle/parton is primary or not.
54076       ELSEIF(MTABU.EQ.21) THEN
54077         NEVFS=NEVFS+1
54078         MSTU(62)=0
54079         DO 260 I=1,N
54080           IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
54081           MSTU(62)=MSTU(62)+1
54082           KC=PYCOMP(K(I,2))
54083           MPRI=0
54084           IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
54085             MPRI=1
54086           ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
54087             MPRI=1
54088           ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
54089             MPRI=1
54090           ELSEIF(KC.EQ.0) THEN
54091           ELSEIF(K(K(I,3),1).EQ.13) THEN
54092             IM=K(K(I,3),3)
54093             IF(IM.LE.0.OR.IM.GT.N) THEN
54094               MPRI=1
54095             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
54096               MPRI=1
54097             ENDIF
54098           ELSEIF(KCHG(KC,2).EQ.0) THEN
54099             KCM=PYCOMP(K(K(I,3),2))
54100             IF(KCM.NE.0) THEN
54101               IF(KCHG(KCM,2).NE.0) MPRI=1
54102             ENDIF
54103           ENDIF
54104           IF(KC.NE.0.AND.MPRI.EQ.1) THEN
54105             IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
54106           ENDIF
54107           IF(K(I,1).LE.10) THEN
54108             NFIFS=NFIFS+1
54109             IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
54110           ENDIF
54111
54112 C...Fill statistics on number of particles/partons in event.
54113           KFA=IABS(K(I,2))
54114           KFS=3-ISIGN(1,K(I,2))-MPRI
54115           DO 210 IP=1,NKFFS
54116             IF(KFA.EQ.KFFS(IP)) THEN
54117               IKFFS=-IP
54118               GOTO 220
54119             ELSEIF(KFA.LT.KFFS(IP)) THEN
54120               IKFFS=IP
54121               GOTO 220
54122             ENDIF
54123   210     CONTINUE
54124           IKFFS=NKFFS+1
54125   220     IF(IKFFS.LT.0) THEN
54126             IKFFS=-IKFFS
54127           ELSE
54128             IF(NKFFS.GE.400) RETURN
54129             DO 240 IP=NKFFS,IKFFS,-1
54130               KFFS(IP+1)=KFFS(IP)
54131               DO 230 J=1,4
54132                 NPFS(IP+1,J)=NPFS(IP,J)
54133   230         CONTINUE
54134   240       CONTINUE
54135             NKFFS=NKFFS+1
54136             KFFS(IKFFS)=KFA
54137             DO 250 J=1,4
54138               NPFS(IKFFS,J)=0
54139   250       CONTINUE
54140           ENDIF
54141           NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
54142   260   CONTINUE
54143
54144 C...Write statistics on particle/parton composition of events.
54145       ELSEIF(MTABU.EQ.22) THEN
54146         FAC=1D0/MAX(1,NEVFS)
54147         WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
54148         DO 270 I=1,NKFFS
54149           CALL PYNAME(KFFS(I),CHAU)
54150           KC=PYCOMP(KFFS(I))
54151           MDCYF=0
54152           IF(KC.NE.0) MDCYF=MDCY(KC,1)
54153           WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
54154      &    FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
54155   270   CONTINUE
54156
54157 C...Copy particle/parton composition information into /PYJETS/.
54158       ELSEIF(MTABU.EQ.23) THEN
54159         FAC=1D0/MAX(1,NEVFS)
54160         DO 290 I=1,NKFFS
54161           K(I,1)=32
54162           K(I,2)=99
54163           K(I,3)=KFFS(I)
54164           K(I,4)=0
54165           K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
54166           DO 280 J=1,4
54167             P(I,J)=FAC*NPFS(I,J)
54168             V(I,J)=0D0
54169   280     CONTINUE
54170           P(I,5)=FAC*K(I,5)
54171           V(I,5)=0D0
54172   290   CONTINUE
54173         N=NKFFS
54174         DO 300 J=1,5
54175           K(N+1,J)=0
54176           P(N+1,J)=0D0
54177           V(N+1,J)=0D0
54178   300   CONTINUE
54179         K(N+1,1)=32
54180         K(N+1,2)=99
54181         K(N+1,5)=NEVFS
54182         P(N+1,1)=FAC*NPRFS
54183         P(N+1,2)=FAC*NFIFS
54184         P(N+1,3)=FAC*NCHFS
54185         MSTU(3)=1
54186
54187 C...Reset factorial moments statistics.
54188       ELSEIF(MTABU.EQ.30) THEN
54189         NEVFM=0
54190         NMUFM=0
54191         DO 330 IM=1,3
54192           DO 320 IB=1,10
54193             DO 310 IP=1,4
54194               FM1FM(IM,IB,IP)=0D0
54195               FM2FM(IM,IB,IP)=0D0
54196   310       CONTINUE
54197   320     CONTINUE
54198   330   CONTINUE
54199
54200 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
54201       ELSEIF(MTABU.EQ.31) THEN
54202         NEVFM=NEVFM+1
54203         NLOW=N+MSTU(3)
54204         NUPP=NLOW
54205         DO 410 I=1,N
54206           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
54207           IF(MSTU(41).GE.2) THEN
54208             KC=PYCOMP(K(I,2))
54209             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54210      &      KC.EQ.18) GOTO 410
54211             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54212      &      PYCHGE(K(I,2)).EQ.0) GOTO 410
54213           ENDIF
54214           PMR=0D0
54215           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54216           IF(MSTU(42).GE.2) PMR=P(I,5)
54217           PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
54218           YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
54219      &    1D20)),P(I,3))
54220           IF(ABS(YETA).GT.PARU(57)) GOTO 410
54221           PHI=PYANGL(P(I,1),P(I,2))
54222           IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
54223           IYETA=MAX(0,MIN(511,IYETA))
54224           IPHI=512D0*(PHI+PARU(1))/PARU(2)
54225           IPHI=MAX(0,MIN(511,IPHI))
54226           IYEP=0
54227           DO 340 IB=0,9
54228             IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
54229   340     CONTINUE
54230
54231 C...Order particles in (pseudo)rapidity and/or azimuth.
54232           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54233             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54234             RETURN
54235           ENDIF
54236           NUPP=NUPP+1
54237           IF(NUPP.EQ.NLOW+1) THEN
54238             K(NUPP,1)=IYETA
54239             K(NUPP,2)=IPHI
54240             K(NUPP,3)=IYEP
54241           ELSE
54242             DO 350 I1=NUPP-1,NLOW+1,-1
54243               IF(IYETA.GE.K(I1,1)) GOTO 360
54244               K(I1+1,1)=K(I1,1)
54245   350       CONTINUE
54246   360       K(I1+1,1)=IYETA
54247             DO 370 I1=NUPP-1,NLOW+1,-1
54248               IF(IPHI.GE.K(I1,2)) GOTO 380
54249               K(I1+1,2)=K(I1,2)
54250   370       CONTINUE
54251   380       K(I1+1,2)=IPHI
54252             DO 390 I1=NUPP-1,NLOW+1,-1
54253               IF(IYEP.GE.K(I1,3)) GOTO 400
54254               K(I1+1,3)=K(I1,3)
54255   390       CONTINUE
54256   400       K(I1+1,3)=IYEP
54257           ENDIF
54258   410   CONTINUE
54259         K(NUPP+1,1)=2**10
54260         K(NUPP+1,2)=2**10
54261         K(NUPP+1,3)=4**10
54262
54263 C...Calculate sum of factorial moments in event.
54264         DO 480 IM=1,3
54265           DO 430 IB=1,10
54266             DO 420 IP=1,4
54267               FEVFM(IB,IP)=0D0
54268   420       CONTINUE
54269   430     CONTINUE
54270           DO 450 IB=1,10
54271             IF(IM.LE.2) IBIN=2**(10-IB)
54272             IF(IM.EQ.3) IBIN=4**(10-IB)
54273             IAGR=K(NLOW+1,IM)/IBIN
54274             NAGR=1
54275             DO 440 I=NLOW+2,NUPP+1
54276               ICUT=K(I,IM)/IBIN
54277               IF(ICUT.EQ.IAGR) THEN
54278                 NAGR=NAGR+1
54279               ELSE
54280                 IF(NAGR.EQ.1) THEN
54281                 ELSEIF(NAGR.EQ.2) THEN
54282                   FEVFM(IB,1)=FEVFM(IB,1)+2D0
54283                 ELSEIF(NAGR.EQ.3) THEN
54284                   FEVFM(IB,1)=FEVFM(IB,1)+6D0
54285                   FEVFM(IB,2)=FEVFM(IB,2)+6D0
54286                 ELSEIF(NAGR.EQ.4) THEN
54287                   FEVFM(IB,1)=FEVFM(IB,1)+12D0
54288                   FEVFM(IB,2)=FEVFM(IB,2)+24D0
54289                   FEVFM(IB,3)=FEVFM(IB,3)+24D0
54290                 ELSE
54291                   FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
54292                   FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
54293                   FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54294      &            (NAGR-3D0)
54295                   FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54296      &            (NAGR-3D0)*(NAGR-4D0)
54297                 ENDIF
54298                 IAGR=ICUT
54299                 NAGR=1
54300               ENDIF
54301   440       CONTINUE
54302   450     CONTINUE
54303
54304 C...Add results to total statistics.
54305           DO 470 IB=10,1,-1
54306             DO 460 IP=1,4
54307               IF(FEVFM(1,IP).LT.0.5D0) THEN
54308                 FEVFM(IB,IP)=0D0
54309               ELSEIF(IM.LE.2) THEN
54310                 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54311               ELSE
54312                 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54313               ENDIF
54314               FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
54315               FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
54316   460       CONTINUE
54317   470     CONTINUE
54318   480   CONTINUE
54319         NMUFM=NMUFM+(NUPP-NLOW)
54320         MSTU(62)=NUPP-NLOW
54321
54322 C...Write accumulated statistics on factorial moments.
54323       ELSEIF(MTABU.EQ.32) THEN
54324         FAC=1D0/MAX(1,NEVFM)
54325         IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
54326         IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
54327         IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y  '
54328         DO 510 IM=1,3
54329           WRITE(MSTU(11),5500)
54330           DO 500 IB=1,10
54331             BYETA=2D0*PARU(57)
54332             IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
54333             BPHI=PARU(2)
54334             IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
54335             IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
54336             IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
54337             DO 490 IP=1,4
54338               FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
54339               FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54340      &        FMOMA(IP)**2)))
54341   490       CONTINUE
54342             WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
54343      &      IP=1,4)
54344   500     CONTINUE
54345   510   CONTINUE
54346
54347 C...Copy statistics on factorial moments into /PYJETS/.
54348       ELSEIF(MTABU.EQ.33) THEN
54349         FAC=1D0/MAX(1,NEVFM)
54350         DO 540 IM=1,3
54351           DO 530 IB=1,10
54352             I=10*(IM-1)+IB
54353             K(I,1)=32
54354             K(I,2)=99
54355             K(I,3)=1
54356             IF(IM.NE.2) K(I,3)=2**(IB-1)
54357             K(I,4)=1
54358             IF(IM.NE.1) K(I,4)=2**(IB-1)
54359             K(I,5)=0
54360             P(I,1)=2D0*PARU(57)/K(I,3)
54361             V(I,1)=PARU(2)/K(I,4)
54362             DO 520 IP=1,4
54363               P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
54364               V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54365      &        P(I,IP+1)**2)))
54366   520       CONTINUE
54367   530     CONTINUE
54368   540   CONTINUE
54369         N=30
54370         DO 550 J=1,5
54371           K(N+1,J)=0
54372           P(N+1,J)=0D0
54373           V(N+1,J)=0D0
54374   550   CONTINUE
54375         K(N+1,1)=32
54376         K(N+1,2)=99
54377         K(N+1,5)=NEVFM
54378         MSTU(3)=1
54379
54380 C...Reset statistics on Energy-Energy Correlation.
54381       ELSEIF(MTABU.EQ.40) THEN
54382         NEVEE=0
54383         DO 560 J=1,25
54384           FE1EC(J)=0D0
54385           FE2EC(J)=0D0
54386           FE1EC(51-J)=0D0
54387           FE2EC(51-J)=0D0
54388           FE1EA(J)=0D0
54389           FE2EA(J)=0D0
54390   560   CONTINUE
54391
54392 C...Find particles to include, with proper assumed mass.
54393       ELSEIF(MTABU.EQ.41) THEN
54394         NEVEE=NEVEE+1
54395         NLOW=N+MSTU(3)
54396         NUPP=NLOW
54397         ECM=0D0
54398         DO 570 I=1,N
54399           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
54400           IF(MSTU(41).GE.2) THEN
54401             KC=PYCOMP(K(I,2))
54402             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54403      &      KC.EQ.18) GOTO 570
54404             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54405      &      PYCHGE(K(I,2)).EQ.0) GOTO 570
54406           ENDIF
54407           PMR=0D0
54408           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54409           IF(MSTU(42).GE.2) PMR=P(I,5)
54410           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54411             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54412             RETURN
54413           ENDIF
54414           NUPP=NUPP+1
54415           P(NUPP,1)=P(I,1)
54416           P(NUPP,2)=P(I,2)
54417           P(NUPP,3)=P(I,3)
54418           P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
54419           P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
54420           ECM=ECM+P(NUPP,4)
54421   570   CONTINUE
54422         IF(NUPP.EQ.NLOW) RETURN
54423
54424 C...Analyze Energy-Energy Correlation in event.
54425         FAC=(2D0/ECM**2)*50D0/PARU(1)
54426         DO 580 J=1,50
54427           FEVEE(J)=0D0
54428   580   CONTINUE
54429         DO 600 I1=NLOW+2,NUPP
54430           DO 590 I2=NLOW+1,I1-1
54431             CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
54432      &      (P(I1,5)*P(I2,5))
54433             THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
54434             ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
54435             FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
54436   590     CONTINUE
54437   600   CONTINUE
54438         DO 610 J=1,25
54439           FE1EC(J)=FE1EC(J)+FEVEE(J)
54440           FE2EC(J)=FE2EC(J)+FEVEE(J)**2
54441           FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
54442           FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
54443           FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
54444           FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
54445   610   CONTINUE
54446         MSTU(62)=NUPP-NLOW
54447
54448 C...Write statistics on Energy-Energy Correlation.
54449       ELSEIF(MTABU.EQ.42) THEN
54450         FAC=1D0/MAX(1,NEVEE)
54451         WRITE(MSTU(11),5700) NEVEE
54452         DO 620 J=1,25
54453           FEEC1=FAC*FE1EC(J)
54454           FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
54455           FEEC2=FAC*FE1EC(51-J)
54456           FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
54457           FEECA=FAC*FE1EA(J)
54458           FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
54459           WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
54460      &    FEEC2,FEES2,FEECA,FEESA
54461   620   CONTINUE
54462
54463 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
54464       ELSEIF(MTABU.EQ.43) THEN
54465         FAC=1D0/MAX(1,NEVEE)
54466         DO 630 I=1,25
54467           K(I,1)=32
54468           K(I,2)=99
54469           K(I,3)=0
54470           K(I,4)=0
54471           K(I,5)=0
54472           P(I,1)=FAC*FE1EC(I)
54473           V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
54474           P(I,2)=FAC*FE1EC(51-I)
54475           V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
54476           P(I,3)=FAC*FE1EA(I)
54477           V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
54478           P(I,4)=PARU(1)*(I-1)/50D0
54479           P(I,5)=PARU(1)*I/50D0
54480           V(I,4)=3.6D0*(I-1)
54481           V(I,5)=3.6D0*I
54482   630   CONTINUE
54483         N=25
54484         DO 640 J=1,5
54485           K(N+1,J)=0
54486           P(N+1,J)=0D0
54487           V(N+1,J)=0D0
54488   640   CONTINUE
54489         K(N+1,1)=32
54490         K(N+1,2)=99
54491         K(N+1,5)=NEVEE
54492         MSTU(3)=1
54493
54494 C...Reset statistics on decay channels.
54495       ELSEIF(MTABU.EQ.50) THEN
54496         NEVDC=0
54497         NKFDC=0
54498         NREDC=0
54499
54500 C...Identify and order flavour content of final state.
54501       ELSEIF(MTABU.EQ.51) THEN
54502         NEVDC=NEVDC+1
54503         NDS=0
54504         DO 670 I=1,N
54505           IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
54506           NDS=NDS+1
54507           IF(NDS.GT.8) THEN
54508             NREDC=NREDC+1
54509             RETURN
54510           ENDIF
54511           KFM=2*IABS(K(I,2))
54512           IF(K(I,2).LT.0) KFM=KFM-1
54513           DO 650 IDS=NDS-1,1,-1
54514             IIN=IDS+1
54515             IF(KFM.LT.KFDM(IDS)) GOTO 660
54516             KFDM(IDS+1)=KFDM(IDS)
54517   650     CONTINUE
54518           IIN=1
54519   660     KFDM(IIN)=KFM
54520   670   CONTINUE
54521
54522 C...Find whether old or new final state.
54523         DO 690 IDC=1,NKFDC
54524           IF(NDS.LT.KFDC(IDC,0)) THEN
54525             IKFDC=IDC
54526             GOTO 700
54527           ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
54528             DO 680 I=1,NDS
54529               IF(KFDM(I).LT.KFDC(IDC,I)) THEN
54530                 IKFDC=IDC
54531                 GOTO 700
54532               ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
54533                 GOTO 690
54534               ENDIF
54535   680       CONTINUE
54536             IKFDC=-IDC
54537             GOTO 700
54538           ENDIF
54539   690   CONTINUE
54540         IKFDC=NKFDC+1
54541   700   IF(IKFDC.LT.0) THEN
54542           IKFDC=-IKFDC
54543         ELSEIF(NKFDC.GE.200) THEN
54544           NREDC=NREDC+1
54545           RETURN
54546         ELSE
54547           DO 720 IDC=NKFDC,IKFDC,-1
54548             NPDC(IDC+1)=NPDC(IDC)
54549             DO 710 I=0,8
54550               KFDC(IDC+1,I)=KFDC(IDC,I)
54551   710       CONTINUE
54552   720     CONTINUE
54553           NKFDC=NKFDC+1
54554           KFDC(IKFDC,0)=NDS
54555           DO 730 I=1,NDS
54556             KFDC(IKFDC,I)=KFDM(I)
54557   730     CONTINUE
54558           NPDC(IKFDC)=0
54559         ENDIF
54560         NPDC(IKFDC)=NPDC(IKFDC)+1
54561
54562 C...Write statistics on decay channels.
54563       ELSEIF(MTABU.EQ.52) THEN
54564         FAC=1D0/MAX(1,NEVDC)
54565         WRITE(MSTU(11),5900) NEVDC
54566         DO 750 IDC=1,NKFDC
54567           DO 740 I=1,KFDC(IDC,0)
54568             KFM=KFDC(IDC,I)
54569             KF=(KFM+1)/2
54570             IF(2*KF.NE.KFM) KF=-KF
54571             CALL PYNAME(KF,CHAU)
54572             CHDC(I)=CHAU(1:12)
54573             IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
54574   740     CONTINUE
54575           WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
54576   750   CONTINUE
54577         IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
54578
54579 C...Copy statistics on decay channels into /PYJETS/.
54580       ELSEIF(MTABU.EQ.53) THEN
54581         FAC=1D0/MAX(1,NEVDC)
54582         DO 780 IDC=1,NKFDC
54583           K(IDC,1)=32
54584           K(IDC,2)=99
54585           K(IDC,3)=0
54586           K(IDC,4)=0
54587           K(IDC,5)=KFDC(IDC,0)
54588           DO 760 J=1,5
54589             P(IDC,J)=0D0
54590             V(IDC,J)=0D0
54591   760     CONTINUE
54592           DO 770 I=1,KFDC(IDC,0)
54593             KFM=KFDC(IDC,I)
54594             KF=(KFM+1)/2
54595             IF(2*KF.NE.KFM) KF=-KF
54596             IF(I.LE.5) P(IDC,I)=KF
54597             IF(I.GE.6) V(IDC,I-5)=KF
54598   770     CONTINUE
54599           V(IDC,5)=FAC*NPDC(IDC)
54600   780   CONTINUE
54601         N=NKFDC
54602         DO 790 J=1,5
54603           K(N+1,J)=0
54604           P(N+1,J)=0D0
54605           V(N+1,J)=0D0
54606   790   CONTINUE
54607         K(N+1,1)=32
54608         K(N+1,2)=99
54609         K(N+1,5)=NEVDC
54610         V(N+1,5)=FAC*NREDC
54611         MSTU(3)=1
54612       ENDIF
54613
54614 C...Format statements for output on unit MSTU(11) (default 6).
54615  5000 FORMAT(///20X,'Event statistics - initial state'/
54616      &20X,'based on an analysis of ',I6,' events'//
54617      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
54618      &'according to fragmenting system multiplicity'/
54619      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
54620      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
54621  5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
54622  5200 FORMAT(///20X,'Event statistics - final state'/
54623      &20X,'based on an analysis of ',I7,' events'//
54624      &5X,'Mean primary multiplicity =',F10.4/
54625      &5X,'Mean final   multiplicity =',F10.4/
54626      &5X,'Mean charged multiplicity =',F10.4//
54627      &5X,'Number of particles produced per event (directly and via ',
54628      &'decays/branchings)'/
54629      &8X,'KF    Particle/jet  MDCY',10X,'Particles',13X,'Antiparticles',
54630      &8X,'Total'/35X,'prim        seco        prim        seco'/)
54631  5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
54632  5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
54633      &20X,'based on an analysis of ',I6,' events'//
54634      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
54635      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
54636  5500 FORMAT(10X)
54637  5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
54638  5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
54639      &20X,'based on an analysis of ',I6,' events'//
54640      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
54641      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
54642  5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
54643  5900 FORMAT(///20X,'Decay channel analysis - final state'/
54644      &20X,'based on an analysis of ',I6,' events'//
54645      &2X,'Probability',10X,'Complete final state'/)
54646  6000 FORMAT(2X,F9.5,5X,8(A12,1X))
54647  6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
54648      &'or table overflow)')
54649
54650       RETURN
54651       END
54652
54653 C*********************************************************************
54654
54655 C...PYEEVT
54656 C...Handles the generation of an e+e- annihilation jet event.
54657
54658       SUBROUTINE PYEEVT(KFL,ECM)
54659
54660 C...Double precision and integer declarations.
54661       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54662       IMPLICIT INTEGER(I-N)
54663       INTEGER PYK,PYCHGE,PYCOMP
54664 C...Commonblocks.
54665       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54666       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54667       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54668       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54669
54670 C...Check input parameters.
54671       IF(MSTU(12).GE.1) CALL PYLIST(0)
54672       IF(KFL.LT.0.OR.KFL.GT.8) THEN
54673         CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
54674         IF(MSTU(21).GE.1) RETURN
54675       ENDIF
54676       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
54677       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
54678       IF(ECM.LT.ECMMIN) THEN
54679         CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
54680         IF(MSTU(21).GE.1) RETURN
54681       ENDIF
54682
54683 C...Check consistency of MSTJ options set.
54684       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
54685         CALL PYERRM(6,
54686      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
54687         MSTJ(110)=1
54688       ENDIF
54689       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
54690         CALL PYERRM(6,
54691      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
54692         MSTJ(111)=0
54693       ENDIF
54694
54695 C...Initialize alpha_strong and total cross-section.
54696       MSTU(111)=MSTJ(108)
54697       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
54698      &MSTU(111)=1
54699       PARU(112)=PARJ(121)
54700       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
54701       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
54702      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
54703      &XTOT)
54704       IF(MSTJ(116).GE.3) MSTJ(116)=1
54705       PARJ(171)=0D0
54706
54707 C...Add initial e+e- to event record (documentation only).
54708       NTRY=0
54709   100 NTRY=NTRY+1
54710       IF(NTRY.GT.100) THEN
54711         CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
54712         RETURN
54713       ENDIF
54714       MSTU(24)=0
54715       NC=0
54716       IF(MSTJ(115).GE.2) THEN
54717         NC=NC+2
54718         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
54719         K(NC-1,1)=21
54720         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
54721         K(NC,1)=21
54722       ENDIF
54723
54724 C...Radiative photon (in initial state).
54725       MK=0
54726       ECMC=ECM
54727       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
54728      &THEK,PHIK,ALPK)
54729       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
54730       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
54731         NC=NC+1
54732         CALL PY1ENT(NC,22,PAK,THEK,PHIK)
54733         K(NC,3)=MIN(MSTJ(115)/2,1)
54734       ENDIF
54735
54736 C...Virtual exchange boson (gamma or Z0).
54737       IF(MSTJ(115).GE.3) THEN
54738         NC=NC+1
54739         KF=22
54740         IF(MSTJ(102).EQ.2) KF=23
54741         MSTU10=MSTU(10)
54742         MSTU(10)=1
54743         P(NC,5)=ECMC
54744         CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
54745         K(NC,1)=21
54746         K(NC,3)=1
54747         MSTU(10)=MSTU10
54748       ENDIF
54749
54750 C...Choice of flavour and jet configuration.
54751       CALL PYXKFL(KFL,ECM,ECMC,KFLC)
54752       IF(KFLC.EQ.0) GOTO 100
54753       CALL PYXJET(ECMC,NJET,CUT)
54754       KFLN=21
54755       IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
54756      &X12,X14)
54757       IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
54758       IF(NJET.EQ.2) MSTJ(120)=1
54759
54760 C...Fill jet configuration and origin.
54761       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
54762       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
54763      &ECMC)
54764       IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
54765       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
54766      &-KFLC,ECMC,X1,X2,X4,X12,X14)
54767       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
54768      &-KFLC,ECMC,X1,X2,X4,X12,X14)
54769       IF(MSTU(24).NE.0) GOTO 100
54770       DO 110 IP=NC+1,N
54771         K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
54772   110 CONTINUE
54773
54774 C...Angular orientation according to matrix element.
54775       IF(MSTJ(106).EQ.1) THEN
54776         CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
54777         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
54778         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
54779       ENDIF
54780
54781 C...Rotation and boost from radiative photon.
54782       IF(MK.EQ.1) THEN
54783         DBEK=-PAK/(ECM-PAK)
54784         NMIN=NC+1-MSTJ(115)/3
54785         CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
54786         CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
54787         CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
54788       ENDIF
54789
54790 C...Generate parton shower. Rearrange along strings and check.
54791       IF(MSTJ(101).EQ.5) THEN
54792         CALL PYSHOW(N-1,N,ECMC)
54793         MSTJ14=MSTJ(14)
54794         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
54795         IF(MSTJ(105).GE.0) MSTU(28)=0
54796         CALL PYPREP(0)
54797         MSTJ(14)=MSTJ14
54798         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
54799       ENDIF
54800
54801 C...Fragmentation/decay generation. Information for PYTABU.
54802       IF(MSTJ(105).EQ.1) CALL PYEXEC
54803       MSTU(161)=KFLC
54804       MSTU(162)=-KFLC
54805
54806       RETURN
54807       END
54808
54809 C*********************************************************************
54810
54811 C...PYXTEE
54812 C...Calculates total cross-section, including initial state
54813 C...radiation effects.
54814
54815       SUBROUTINE PYXTEE(KFL,ECM,XTOT)
54816
54817 C...Double precision and integer declarations.
54818       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54819       IMPLICIT INTEGER(I-N)
54820       INTEGER PYK,PYCHGE,PYCOMP
54821 C...Commonblocks.
54822       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54823       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54824       SAVE /PYDAT1/,/PYDAT2/
54825
54826 C...Status, (optimized) Q^2 scale, alpha_strong.
54827       PARJ(151)=ECM
54828       MSTJ(119)=10*MSTJ(102)+KFL
54829       IF(MSTJ(111).EQ.0) THEN
54830         Q2R=ECM**2
54831       ELSEIF(MSTU(111).EQ.0) THEN
54832         PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
54833      &  ((33D0-2D0*MSTU(112))*PARU(111)))))
54834         Q2R=PARJ(168)*ECM**2
54835       ELSE
54836         PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
54837      &  (2D0*PARU(112)/ECM)**2))
54838         Q2R=PARJ(168)*ECM**2
54839       ENDIF
54840       ALSPI=PYALPS(Q2R)/PARU(1)
54841
54842 C...QCD corrections factor in R.
54843       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
54844         RQCD=1D0
54845       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
54846         RQCD=1D0+ALSPI
54847       ELSEIF(MSTJ(109).EQ.0) THEN
54848         RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
54849         IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
54850      &  LOG(PARJ(168))*ALSPI**2)
54851       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
54852         RQCD=1D0+(3D0/4D0)*ALSPI
54853       ELSE
54854         RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
54855       ENDIF
54856
54857 C...Calculate Z0 width if default value not acceptable.
54858       IF(MSTJ(102).GE.3) THEN
54859         RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
54860      &  (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
54861         DO 100 KFLC=5,6
54862           VQ=1D0
54863           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
54864      &    (2D0*PYMASS(KFLC)/ ECM)**2))
54865           IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
54866           IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
54867           RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
54868   100   CONTINUE
54869         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
54870      &  (1D0-PARU(102)))
54871       ENDIF
54872
54873 C...Calculate propagator and related constants for QFD case.
54874       POLL=1D0-PARJ(131)*PARJ(132)
54875       IF(MSTJ(102).GE.2) THEN
54876         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
54877         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
54878         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
54879         VE=4D0*PARU(102)-1D0
54880         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
54881         SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
54882         HF1I=SFI*SF1I
54883         HF1W=SFW*SF1W
54884       ENDIF
54885
54886 C...Loop over different flavours: charge, velocity.
54887       RTOT=0D0
54888       RQQ=0D0
54889       RQV=0D0
54890       RVA=0D0
54891       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
54892         IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
54893         MSTJ(93)=1
54894         PMQ=PYMASS(KFLC)
54895         IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
54896         QF=KCHG(KFLC,1)/3D0
54897         VQ=1D0
54898         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
54899
54900 C...Calculate R and sum of charges for QED or QFD case.
54901         RQQ=RQQ+3D0*QF**2*POLL
54902         IF(MSTJ(102).LE.1) THEN
54903           RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
54904         ELSE
54905           VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
54906           RQV=RQV-6D0*QF*VF*SF1I
54907           RVA=RVA+3D0*(VF**2+1D0)*SF1W
54908           RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
54909      &    2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
54910         ENDIF
54911   110 CONTINUE
54912       RSUM=RQQ
54913       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
54914
54915 C...Calculate cross-section, including QCD corrections.
54916       PARJ(141)=RQQ
54917       PARJ(142)=RTOT
54918       PARJ(143)=RTOT*RQCD
54919       PARJ(144)=PARJ(143)
54920       PARJ(145)=PARJ(141)*86.8D0/ECM**2
54921       PARJ(146)=PARJ(142)*86.8D0/ECM**2
54922       PARJ(147)=PARJ(143)*86.8D0/ECM**2
54923       PARJ(148)=PARJ(147)
54924       PARJ(157)=RSUM*RQCD
54925       PARJ(158)=0D0
54926       PARJ(159)=0D0
54927       XTOT=PARJ(147)
54928       IF(MSTJ(107).LE.0) RETURN
54929
54930 C...Virtual cross-section.
54931       XKL=PARJ(135)
54932       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
54933       ALE=2D0*LOG(ECM/PYMASS(11))-1D0
54934       SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
54935      &1.526D0*LOG(ECM**2/0.932D0)
54936
54937 C...Soft and hard radiative cross-section in QED case.
54938       IF(MSTJ(102).LE.1) THEN
54939         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
54940         SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
54941         SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
54942
54943 C...Soft and hard radiative cross-section in QFD case.
54944       ELSE
54945         SZM=1D0-(PARJ(123)/ECM)**2
54946         SZW=PARJ(123)*PARJ(124)/ECM**2
54947         PARJ(161)=-RQQ/RSUM
54948         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
54949         PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
54950         PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
54951      &  4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
54952         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
54953      &  RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
54954         SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
54955      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
54956      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
54957         SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
54958      &  (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
54959      &  LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
54960      &  PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
54961       ENDIF
54962
54963 C...Total cross-section and fraction of hard photon events.
54964       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
54965       PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
54966       PARJ(144)=PARJ(157)
54967       PARJ(148)=PARJ(144)*86.8D0/ECM**2
54968       XTOT=PARJ(148)
54969
54970       RETURN
54971       END
54972
54973 C*********************************************************************
54974
54975 C...PYRADK
54976 C...Generates initial state photon radiation.
54977
54978       SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
54979
54980 C...Double precision and integer declarations.
54981       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54982       IMPLICIT INTEGER(I-N)
54983       INTEGER PYK,PYCHGE,PYCOMP
54984 C...Commonblocks.
54985       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54986       SAVE /PYDAT1/
54987
54988 C...Function: cumulative hard photon spectrum in QFD case.
54989       FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
54990      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
54991
54992 C...Determine whether radiative photon or not.
54993       MK=0
54994       PAK=0D0
54995       IF(PARJ(160).LT.PYR(0)) RETURN
54996       MK=1
54997
54998 C...Photon energy range. Find photon momentum in QED case.
54999       XKL=PARJ(135)
55000       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
55001       IF(MSTJ(102).LE.1) THEN
55002   100   XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
55003         IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
55004
55005 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
55006       ELSE
55007         SZM=1D0-(PARJ(123)/ECM)**2
55008         SZW=PARJ(123)*PARJ(124)/ECM**2
55009         FXKL=FXK(XKL)
55010         FXKU=FXK(XKU)
55011         FXKD=1D-4*(FXKU-FXKL)
55012         FXKR=FXKL+PYR(0)*(FXKU-FXKL)
55013         NXK=0
55014   110   NXK=NXK+1
55015         XK=0.5D0*(XKL+XKU)
55016         FXKV=FXK(XK)
55017         IF(FXKV.GT.FXKR) THEN
55018           XKU=XK
55019           FXKU=FXKV
55020         ELSE
55021           XKL=XK
55022           FXKL=FXKV
55023         ENDIF
55024         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
55025         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
55026       ENDIF
55027       PAK=0.5D0*ECM*XK
55028
55029 C...Photon polar and azimuthal angle.
55030       PME=2D0*(PYMASS(11)/ECM)**2
55031   120 CTHM=PME*(2D0/PME)**PYR(0)
55032       IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
55033      &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
55034       CTHE=1D0-CTHM
55035       IF(PYR(0).GT.0.5D0) CTHE=-CTHE
55036       STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
55037       THEK=PYANGL(CTHE,STHE)
55038       PHIK=PARU(2)*PYR(0)
55039
55040 C...Rotation angle for hadronic system.
55041       SGN=1D0
55042       IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
55043      &PYR(0)) SGN=-1D0
55044       ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
55045      &(2D0-XK*(1D0-SGN*CTHE)))
55046
55047       RETURN
55048       END
55049
55050 C*********************************************************************
55051
55052 C...PYXKFL
55053 C...Selects flavour for produced qqbar pair.
55054
55055       SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
55056
55057 C...Double precision and integer declarations.
55058       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55059       IMPLICIT INTEGER(I-N)
55060       INTEGER PYK,PYCHGE,PYCOMP
55061 C...Commonblocks.
55062       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55063       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55064       SAVE /PYDAT1/,/PYDAT2/
55065
55066 C...Calculate maximum weight in QED or QFD case.
55067       IF(MSTJ(102).LE.1) THEN
55068         RFMAX=4D0/9D0
55069       ELSE
55070         POLL=1D0-PARJ(131)*PARJ(132)
55071         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55072         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55073         SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
55074         VE=4D0*PARU(102)-1D0
55075         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
55076         HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
55077         RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
55078      &  ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
55079      &  (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
55080      &  1D0)*HF1W)
55081       ENDIF
55082
55083 C...Choose flavour. Gives charge and velocity.
55084       NTRY=0
55085   100 NTRY=NTRY+1
55086       IF(NTRY.GT.100) THEN
55087         CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
55088         KFLC=0
55089         RETURN
55090       ENDIF
55091       KFLC=KFL
55092       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
55093       MSTJ(93)=1
55094       PMQ=PYMASS(KFLC)
55095       IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
55096       QF=KCHG(KFLC,1)/3D0
55097       VQ=1D0
55098       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
55099
55100 C...Calculate weight in QED or QFD case.
55101       IF(MSTJ(102).LE.1) THEN
55102         RF=QF**2
55103         RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
55104       ELSE
55105         VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
55106         RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
55107         RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
55108      &  VQ**3*HF1W
55109         IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
55110       ENDIF
55111
55112 C...Weighting or new event (radiative photon). Cross-section update.
55113       IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
55114       PARJ(158)=PARJ(158)+1D0
55115       IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
55116       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
55117       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
55118       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
55119       PARJ(148)=PARJ(144)*86.8D0/ECM**2
55120
55121       RETURN
55122       END
55123
55124 C*********************************************************************
55125
55126 C...PYXJET
55127 C...Selects number of jets in matrix element approach.
55128
55129       SUBROUTINE PYXJET(ECM,NJET,CUT)
55130
55131 C...Double precision and integer declarations.
55132       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55133       IMPLICIT INTEGER(I-N)
55134       INTEGER PYK,PYCHGE,PYCOMP
55135 C...Commonblocks.
55136       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55137       SAVE /PYDAT1/
55138 C...Local array and data.
55139       DIMENSION ZHUT(5)
55140       DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
55141
55142 C...Trivial result for two-jets only, including parton shower.
55143       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55144         CUT=0D0
55145
55146 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
55147       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
55148         CF=4D0/3D0
55149         IF(MSTJ(109).EQ.2) CF=1D0
55150         IF(MSTJ(111).EQ.0) THEN
55151           Q2=ECM**2
55152           Q2R=ECM**2
55153         ELSEIF(MSTU(111).EQ.0) THEN
55154           PARJ(169)=MIN(1D0,PARJ(129))
55155           Q2=PARJ(169)*ECM**2
55156           PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
55157      &    ((33D0-2D0*MSTU(112))*PARU(111)))))
55158           Q2R=PARJ(168)*ECM**2
55159         ELSE
55160           PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
55161           Q2=PARJ(169)*ECM**2
55162           PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
55163      &    (2D0*PARU(112)/ECM)**2))
55164           Q2R=PARJ(168)*ECM**2
55165         ENDIF
55166
55167 C...alpha_strong for R and R itself.
55168         ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
55169         IF(IABS(MSTJ(101)).EQ.1) THEN
55170           RQCD=1D0+ALSPI
55171         ELSEIF(MSTJ(109).EQ.0) THEN
55172           RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
55173           IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
55174      &    (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
55175         ELSE
55176           RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
55177         ENDIF
55178
55179 C...alpha_strong for jet rate. Initial value for y cut.
55180         ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55181         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
55182         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
55183      &  CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
55184         IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55185
55186 C...Parametrization of first order three-jet cross-section.
55187   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
55188           PARJ(152)=0D0
55189         ELSE
55190           PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
55191      &    LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
55192      &    (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
55193      &    (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
55194           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
55195      &    PARJ(152)=0D0
55196         ENDIF
55197
55198 C...Parametrization of second order three-jet cross-section.
55199         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
55200      &  CUT.GE.0.25D0) THEN
55201           PARJ(153)=0D0
55202         ELSEIF(MSTJ(110).LE.1) THEN
55203           CT=LOG(1D0/CUT-2D0)
55204           PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
55205      &    0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
55206
55207 C...Interpolation in second/first order ratio for Zhu parametrization.
55208         ELSEIF(MSTJ(110).EQ.2) THEN
55209           IZA=0
55210           DO 110 IY=1,5
55211             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55212   110     CONTINUE
55213           IF(IZA.NE.0) THEN
55214             ZHURAT=ZHUT(IZA)
55215           ELSE
55216             IZ=100D0*CUT
55217             ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
55218           ENDIF
55219           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
55220         ENDIF
55221
55222 C...Shift in second order three-jet cross-section with optimized Q^2.
55223         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
55224      &  .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
55225      &  (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
55226
55227 C...Parametrization of second order four-jet cross-section.
55228         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
55229           PARJ(154)=0D0
55230         ELSE
55231           CT=LOG(1D0/CUT-5D0)
55232           IF(CUT.LE.0.018D0) THEN
55233             XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
55234             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
55235      &      0.4059D0*CT**2)
55236             XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
55237             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55238           ELSE
55239             XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
55240             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
55241      &      0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
55242             XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
55243      &      0.002093D0*CT**3)
55244             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55245           ENDIF
55246           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
55247           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
55248         ENDIF
55249
55250 C...If negative three-jet rate, change y' optimization parameter.
55251         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
55252      &  PARJ(169).LT.0.99D0) THEN
55253           PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55254           Q2=PARJ(169)*ECM**2
55255           ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55256           GOTO 100
55257         ENDIF
55258
55259 C...If too high cross-section, use harder cuts, or fail.
55260         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
55261           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
55262      &    PARJ(169).LT.0.99D0) THEN
55263             PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55264             Q2=PARJ(169)*ECM**2
55265             ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55266             GOTO 100
55267           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
55268             CALL PYERRM(26,
55269      &      '(PYXJET:) no allowed y cut value for Zhu parametrization')
55270           ENDIF
55271           CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
55272      &    PARJ(154))**(-1D0/3D0)
55273           IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55274           GOTO 100
55275         ENDIF
55276
55277 C...Scalar gluon (first order only).
55278       ELSE
55279         ALSPI=PYALPS(ECM**2)/PARU(1)
55280         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
55281         PARJ(152)=0D0
55282         IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
55283      &  LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
55284         PARJ(153)=0D0
55285         PARJ(154)=0D0
55286       ENDIF
55287
55288 C...Select number of jets.
55289       PARJ(150)=CUT
55290       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55291         NJET=2
55292       ELSEIF(MSTJ(101).LE.0) THEN
55293         NJET=MIN(4,2-MSTJ(101))
55294       ELSE
55295         RNJ=PYR(0)
55296         NJET=2
55297         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
55298         IF(PARJ(154).GT.RNJ) NJET=4
55299       ENDIF
55300
55301       RETURN
55302       END
55303
55304 C*********************************************************************
55305
55306 C...PYX3JT
55307 C...Selects the kinematical variables of three-jet events.
55308
55309       SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
55310
55311 C...Double precision and integer declarations.
55312       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55313       IMPLICIT INTEGER(I-N)
55314       INTEGER PYK,PYCHGE,PYCOMP
55315 C...Commonblocks.
55316       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55317       SAVE /PYDAT1/
55318 C...Local array.
55319       DIMENSION ZHUP(5,12)
55320
55321 C...Coefficients of Zhu second order parametrization.
55322       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
55323      &18.29D0,  89.56D0,  4.541D0,  -52.09D0, -109.8D0,  24.90D0,
55324      &11.63D0,  3.683D0,  17.50D0,0.002440D0, -1.362D0,-0.3537D0,
55325      &11.42D0,  6.299D0, -22.55D0,  -8.915D0,  59.25D0, -5.855D0,
55326      &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
55327      &7.847D0, -3.964D0, -35.83D0,   1.178D0,  29.39D0, 0.2806D0,
55328      &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
55329      &5.441D0, -56.89D0, -50.27D0,   15.13D0,  114.3D0, -18.19D0,
55330      &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
55331      &-17.65D0,  51.44D0, -58.32D0,   70.95D0, -255.7D0, -78.99D0,
55332      &476.9D0,  29.65D0, -239.3D0,  0.4745D0, -1.174D0,  6.081D0/
55333
55334 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
55335       DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
55336      &X**7/49D0
55337
55338 C...Event type. Mass effect factors and other common constants.
55339       MSTJ(120)=2
55340       MSTJ(121)=0
55341       PMQ=PYMASS(KFL)
55342       QME=(2D0*PMQ/ECM)**2
55343       IF(MSTJ(109).NE.1) THEN
55344         CUTL=LOG(CUT)
55345         CUTD=LOG(1D0/CUT-2D0)
55346         IF(MSTJ(109).EQ.0) THEN
55347           CF=4D0/3D0
55348           CN=3D0
55349           TR=2D0
55350           WTMX=MIN(20D0,37D0-6D0*CUTD)
55351           IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
55352         ELSE
55353           CF=1D0
55354           CN=0D0
55355           TR=12D0
55356           WTMX=0D0
55357         ENDIF
55358
55359 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
55360         ALS2PI=PARU(118)/PARU(2)
55361         WTOPT=0D0
55362         IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
55363      &  LOG(PARJ(169))*ALS2PI
55364         WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
55365
55366 C...Choose three-jet events in allowed region.
55367   100   NJET=3
55368   110   Y13L=CUTL+CUTD*PYR(0)
55369         Y23L=CUTL+CUTD*PYR(0)
55370         Y13=EXP(Y13L)
55371         Y23=EXP(Y23L)
55372         Y12=1D0-Y13-Y23
55373         IF(Y12.LE.CUT) GOTO 110
55374         IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
55375
55376 C...Second order corrections.
55377         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
55378           Y12L=LOG(Y12)
55379           Y13M=LOG(1D0-Y13)
55380           Y23M=LOG(1D0-Y23)
55381           Y12M=LOG(1D0-Y12)
55382           IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
55383           IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
55384           IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
55385           IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
55386           IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
55387           IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
55388           WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
55389           WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
55390      &    2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
55391      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
55392      &    11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
55393      &    (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
55394      &    TR*(2D0*CUTL/3D0-10D0/9D0)+
55395      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
55396      &    Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
55397      &    (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
55398      &    Y13*Y23)/(Y12+Y13)**2)/WT1+
55399      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
55400      &    ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
55401      &    Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
55402      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
55403      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
55404      &    2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
55405      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
55406           IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55407           IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55408           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
55409
55410         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
55411 C...Second order corrections; Zhu parametrization of ERT.
55412           ZX=(Y23-Y13)**2
55413           ZY=1D0-Y12
55414           IZA=0
55415           DO 120 IY=1,5
55416             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55417   120     CONTINUE
55418           IF(IZA.NE.0) THEN
55419             IZ=IZA
55420             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55421      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55422      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55423      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55424           ELSE
55425             IZ=100D0*CUT
55426             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55427      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55428      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55429      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55430             IZ=IZ+1
55431             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55432      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55433      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55434      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55435             WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
55436           ENDIF
55437           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55438           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55439           PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
55440         ENDIF
55441
55442 C...Impose mass cuts (gives two jets). For fixed jet number new try.
55443         X1=1D0-Y23
55444         X2=1D0-Y13
55445         X3=1D0-Y12
55446         IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
55447         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
55448      &  0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
55449      &  (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
55450         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
55451
55452 C...Scalar gluon model (first order only, no mass effects).
55453       ELSE
55454   130   NJET=3
55455   140   X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
55456         IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
55457         YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
55458         X1=1D0-0.5D0*(X3+YD)
55459         X2=1D0-0.5D0*(X3-YD)
55460         IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
55461         IF(MSTJ(102).GE.2) THEN
55462           IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
55463      &    X3**2*PYR(0)) NJET=2
55464         ENDIF
55465         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
55466       ENDIF
55467
55468       RETURN
55469       END
55470
55471 C*********************************************************************
55472
55473 C...PYX4JT
55474 C...Selects the kinematical variables of four-jet events.
55475
55476       SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
55477
55478 C...Double precision and integer declarations.
55479       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55480       IMPLICIT INTEGER(I-N)
55481       INTEGER PYK,PYCHGE,PYCOMP
55482 C...Commonblocks.
55483       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55484       SAVE /PYDAT1/
55485 C...Local arrays.
55486       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
55487
55488 C...Common constants. Colour factors for QCD and Abelian gluon theory.
55489       PMQ=PYMASS(KFL)
55490       QME=(2D0*PMQ/ECM)**2
55491       CT=LOG(1D0/CUT-5D0)
55492       IF(MSTJ(109).EQ.0) THEN
55493         CF=4D0/3D0
55494         CN=3D0
55495         TR=2.5D0
55496       ELSE
55497         CF=1D0
55498         CN=0D0
55499         TR=15D0
55500       ENDIF
55501
55502 C...Choice of process (qqbargg or qqbarqqbar).
55503   100 NJET=4
55504       IT=1
55505       IF(PARJ(155).GT.PYR(0)) IT=2
55506       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
55507       IF(IT.EQ.1) WTMX=0.7D0/CUT**2
55508       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
55509       IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
55510       ID=1
55511
55512 C...Sample the five kinematical variables (for qqgg preweighted in y34).
55513   110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55514       Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55515       IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
55516       IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
55517       IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
55518       VT=PYR(0)
55519       CP=COS(PARU(1)*PYR(0))
55520       Y14=(Y134-Y34)*VT
55521       Y13=Y134-Y14-Y34
55522       VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
55523       Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
55524      &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
55525       Y23=Y234-Y34-Y24
55526       Y12=1D0-Y134-Y23-Y24
55527       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
55528       Y123=Y12+Y13+Y23
55529       Y124=Y12+Y14+Y24
55530
55531 C...Calculate matrix elements for qqgg or qqqq process.
55532       IC=0
55533       WTTOT=0D0
55534   120 IC=IC+1
55535       IF(IT.EQ.1) THEN
55536         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
55537      &  3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
55538      &  Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
55539      &  Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
55540      &  2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
55541      &  (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
55542      &  Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
55543      &  (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
55544         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
55545      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
55546      &  Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
55547      &  Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
55548         WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
55549      &  2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
55550      &  Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
55551      &  3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
55552      &  3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
55553      &  (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
55554      &  3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
55555      &  2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
55556      &  2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
55557      &  3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
55558      &  2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
55559      &  2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
55560         WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
55561      &  4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
55562      &  Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
55563      &  4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
55564      &  2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
55565      &  4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
55566      &  (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
55567      &  2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
55568      &  2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
55569      &  4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
55570      &  Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
55571      &  4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
55572      &  4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
55573      &  2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
55574      &  2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
55575      &  Y12*Y13**2)/(4D0*Y34**2*Y134**2)
55576         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
55577      &  CN*WTC(IC))/8D0
55578       ELSE
55579         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
55580      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
55581      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
55582      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
55583      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
55584      &  Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
55585      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
55586      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
55587      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
55588         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
55589      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
55590      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
55591      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
55592      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
55593      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
55594      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
55595      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
55596         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
55597       ENDIF
55598
55599 C...Permutations of momenta in matrix element. Weighting.
55600   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
55601         YSAV=Y13
55602         Y13=Y14
55603         Y14=YSAV
55604         YSAV=Y23
55605         Y23=Y24
55606         Y24=YSAV
55607         YSAV=Y123
55608         Y123=Y124
55609         Y124=YSAV
55610       ENDIF
55611       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
55612         YSAV=Y13
55613         Y13=Y23
55614         Y23=YSAV
55615         YSAV=Y14
55616         Y14=Y24
55617         Y24=YSAV
55618         YSAV=Y134
55619         Y134=Y234
55620         Y234=YSAV
55621       ENDIF
55622       IF(IC.LE.3) GOTO 120
55623       IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
55624       IC=5
55625
55626 C...qqgg events: string configuration and event type.
55627       IF(IT.EQ.1) THEN
55628         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
55629           PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
55630      &    WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
55631           IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
55632      &    WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
55633           IF(ID.EQ.2) GOTO 130
55634         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
55635           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
55636           IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
55637           IF(ID.EQ.2) GOTO 130
55638         ENDIF
55639         MSTJ(120)=3
55640         IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
55641      &  WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
55642         KFLN=21
55643
55644 C...Mass cuts. Kinematical variables out.
55645         IF(Y12.LE.CUT+QME) NJET=2
55646         IF(NJET.EQ.2) GOTO 150
55647         Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
55648         X1=1D0-(1D0-Q12)*Y234-Q12*Y134
55649         X4=1D0-(1D0-Q12)*Y134-Q12*Y234
55650         X2=1D0-Y124
55651         X12=(1D0-Q12)*Y13+Q12*Y23
55652         X14=Y12-0.5D0*QME
55653         IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55654
55655 C...qqbarqqbar events: string configuration, choose new flavour.
55656       ELSE
55657         IF(ID.EQ.1) THEN
55658           WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
55659           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
55660           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
55661           IF(WTR.LT.WTD(4)) ID=4
55662           IF(ID.GE.2) GOTO 130
55663         ENDIF
55664         MSTJ(120)=5
55665         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
55666   140   KFLN=1+INT(5D0*PYR(0))
55667         IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
55668         IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
55669         IF(KFLN.GT.MSTJ(104)) NJET=2
55670         PMQN=PYMASS(KFLN)
55671         QMEN=(2D0*PMQN/ECM)**2
55672
55673 C...Mass cuts. Kinematical variables out.
55674         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
55675         IF(NJET.EQ.2) GOTO 150
55676         Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
55677         Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
55678         X1=1D0-(1D0-Q24)*Y123-Q24*Y134
55679         X4=1D0-(1D0-Q24)*Y134-Q24*Y123
55680         X2=1D0-(1D0-Q13)*Y234-Q13*Y124
55681         X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
55682      &  Q13*Y23)
55683         X14=Y24-0.5D0*QME
55684         X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
55685      &  Q13*Y14)
55686         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
55687      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
55688         IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55689       ENDIF
55690   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
55691
55692       RETURN
55693       END
55694
55695 C*********************************************************************
55696
55697 C...PYXDIF
55698 C...Gives the angular orientation of events.
55699
55700       SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
55701
55702 C...Double precision and integer declarations.
55703       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55704       IMPLICIT INTEGER(I-N)
55705       INTEGER PYK,PYCHGE,PYCOMP
55706 C...Commonblocks.
55707       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55708       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55709       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55710       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55711
55712 C...Charge. Factors depending on polarization for QED case.
55713       QF=KCHG(KFL,1)/3D0
55714       POLL=1D0-PARJ(131)*PARJ(132)
55715       POLD=PARJ(132)-PARJ(131)
55716       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
55717         HF1=POLL
55718         HF2=0D0
55719         HF3=PARJ(133)**2
55720         HF4=0D0
55721
55722 C...Factors depending on flavour, energy and polarization for QFD case.
55723       ELSE
55724         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55725         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55726         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
55727         AE=-1D0
55728         VE=4D0*PARU(102)-1D0
55729         AF=SIGN(1D0,QF)
55730         VF=AF-4D0*QF*PARU(102)
55731         HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
55732      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
55733         HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
55734      &  (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
55735         HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
55736      &  SFW*SFF**2*(VE**2-AE**2))
55737         HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
55738      &  SFF*AE
55739       ENDIF
55740
55741 C...Mass factor. Differential cross-sections for two-jet events.
55742       SQ2=SQRT(2D0)
55743       QME=0D0
55744       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
55745      &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
55746       IF(NJET.EQ.2) THEN
55747         SIGU=4D0*SQRT(1D0-QME)
55748         SIGL=2D0*QME*SQRT(1D0-QME)
55749         SIGT=0D0
55750         SIGI=0D0
55751         SIGA=0D0
55752         SIGP=4D0
55753
55754 C...Kinematical variables. Reduce four-jet event to three-jet one.
55755       ELSE
55756         IF(NJET.EQ.3) THEN
55757           X1=2D0*P(NC+1,4)/ECM
55758           X2=2D0*P(NC+3,4)/ECM
55759         ELSE
55760           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
55761      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
55762           X1=2D0*P(NC+1,4)/ECMR
55763           X2=2D0*P(NC+4,4)/ECMR
55764         ENDIF
55765
55766 C...Differential cross-sections for three-jet (or reduced four-jet).
55767         XQ=(1D0-X1)/(1D0-X2)
55768         CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
55769         ST12=SQRT(1D0-CT12**2)
55770         IF(MSTJ(109).NE.1) THEN
55771           SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
55772      &    QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
55773           SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
55774      &    0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
55775      &    X2)*XQ
55776           SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
55777           SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
55778      &    QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
55779           SIGA=X2**2*ST12/SQ2
55780           SIGP=2D0*(X1**2-X2**2*CT12)
55781
55782 C...Differential cross-sect for scalar gluons (no mass effects).
55783         ELSE
55784           X3=2D0-X1-X2
55785           XT=X2*ST12
55786           CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
55787           SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
55788      &    PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
55789           SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
55790      &    PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
55791           SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
55792      &    PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
55793           SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
55794      &    PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
55795           SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
55796           SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
55797         ENDIF
55798       ENDIF
55799
55800 C...Upper bounds for differential cross-section.
55801       HF1A=ABS(HF1)
55802       HF2A=ABS(HF2)
55803       HF3A=ABS(HF3)
55804       HF4A=ABS(HF4)
55805       SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
55806      &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
55807      &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
55808      &2D0*HF2A*ABS(SIGP)
55809
55810 C...Generate angular orientation according to differential cross-sect.
55811   100 CHI=PARU(2)*PYR(0)
55812       CTHE=2D0*PYR(0)-1D0
55813       PHI=PARU(2)*PYR(0)
55814       CCHI=COS(CHI)
55815       SCHI=SIN(CHI)
55816       C2CHI=COS(2D0*CHI)
55817       S2CHI=SIN(2D0*CHI)
55818       THE=ACOS(CTHE)
55819       STHE=SIN(THE)
55820       C2PHI=COS(2D0*(PHI-PARJ(134)))
55821       S2PHI=SIN(2D0*(PHI-PARJ(134)))
55822       SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
55823      &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
55824      &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
55825      &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
55826      &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
55827      &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
55828      &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
55829       IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
55830
55831       RETURN
55832       END
55833
55834 C*********************************************************************
55835
55836 C...PYONIA
55837 C...Generates Upsilon and toponium decays into three gluons
55838 C...or two gluons and a photon.
55839
55840       SUBROUTINE PYONIA(KFL,ECM)
55841
55842 C...Double precision and integer declarations.
55843       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55844       IMPLICIT INTEGER(I-N)
55845       INTEGER PYK,PYCHGE,PYCOMP
55846 C...Commonblocks.
55847       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55848       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55849       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55850       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55851
55852 C...Printout. Check input parameters.
55853       IF(MSTU(12).GE.1) CALL PYLIST(0)
55854       IF(KFL.LT.0.OR.KFL.GT.8) THEN
55855         CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
55856         IF(MSTU(21).GE.1) RETURN
55857       ENDIF
55858       IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
55859         CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
55860         IF(MSTU(21).GE.1) RETURN
55861       ENDIF
55862
55863 C...Initial e+e- and onium state (optional).
55864       NC=0
55865       IF(MSTJ(115).GE.2) THEN
55866         NC=NC+2
55867         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
55868         K(NC-1,1)=21
55869         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
55870         K(NC,1)=21
55871       ENDIF
55872       KFLC=IABS(KFL)
55873       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
55874         NC=NC+1
55875         KF=110*KFLC+3
55876         MSTU10=MSTU(10)
55877         MSTU(10)=1
55878         P(NC,5)=ECM
55879         CALL PY1ENT(NC,KF,ECM,0D0,0D0)
55880         K(NC,1)=21
55881         K(NC,3)=1
55882         MSTU(10)=MSTU10
55883       ENDIF
55884
55885 C...Choose x1 and x2 according to matrix element.
55886       NTRY=0
55887   100 X1=PYR(0)
55888       X2=PYR(0)
55889       X3=2D0-X1-X2
55890       IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
55891      &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
55892       NTRY=NTRY+1
55893       NJET=3
55894       IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
55895       IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
55896
55897 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
55898       MSTU(111)=MSTJ(108)
55899       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
55900      &MSTU(111)=1
55901       PARU(112)=PARJ(121)
55902       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
55903       QF=0D0
55904       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
55905       RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
55906       MK=0
55907       ECMC=ECM
55908       IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
55909         IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
55910      &  NJET=2
55911         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
55912         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
55913       ELSE
55914         MK=1
55915         ECMC=SQRT(1D0-X1)*ECM
55916         IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
55917         K(NC+1,1)=1
55918         K(NC+1,2)=22
55919         K(NC+1,4)=0
55920         K(NC+1,5)=0
55921         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
55922         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
55923         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
55924         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
55925         NJET=2
55926         IF(ECMC.LT.4D0*PARJ(127)) THEN
55927           MSTU10=MSTU(10)
55928           MSTU(10)=1
55929           P(NC+2,5)=ECMC
55930           CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
55931           MSTU(10)=MSTU10
55932           NJET=0
55933         ENDIF
55934       ENDIF
55935       DO 110 IP=NC+1,N
55936         K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
55937   110 CONTINUE
55938
55939 C...Differential cross-sections. Upper limit for cross-section.
55940       IF(MSTJ(106).EQ.1) THEN
55941         SQ2=SQRT(2D0)
55942         HF1=1D0-PARJ(131)*PARJ(132)
55943         HF3=PARJ(133)**2
55944         CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
55945         ST13=SQRT(1D0-CT13**2)
55946         SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
55947         SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
55948         SIGT=0.5D0*SIGL
55949         SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
55950         SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
55951      &  2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
55952
55953 C...Angular orientation of event.
55954   120   CHI=PARU(2)*PYR(0)
55955         CTHE=2D0*PYR(0)-1D0
55956         PHI=PARU(2)*PYR(0)
55957         CCHI=COS(CHI)
55958         SCHI=SIN(CHI)
55959         C2CHI=COS(2D0*CHI)
55960         S2CHI=SIN(2D0*CHI)
55961         THE=ACOS(CTHE)
55962         STHE=SIN(THE)
55963         C2PHI=COS(2D0*(PHI-PARJ(134)))
55964         S2PHI=SIN(2D0*(PHI-PARJ(134)))
55965         SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
55966      &  STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
55967      &  C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
55968      &  2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
55969      &  (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
55970         IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
55971         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
55972         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
55973       ENDIF
55974
55975 C...Generate parton shower. Rearrange along strings and check.
55976       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
55977         CALL PYSHOW(NC+MK+1,-NJET,ECMC)
55978         MSTJ14=MSTJ(14)
55979         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
55980         IF(MSTJ(105).GE.0) MSTU(28)=0
55981         CALL PYPREP(0)
55982         MSTJ(14)=MSTJ14
55983         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
55984       ENDIF
55985
55986 C...Generate fragmentation. Information for PYTABU:
55987       IF(MSTJ(105).EQ.1) CALL PYEXEC
55988       MSTU(161)=110*KFLC+3
55989       MSTU(162)=0
55990
55991       RETURN
55992       END
55993
55994 C*********************************************************************
55995
55996 C...PYBOOK
55997 C...Books a histogram.
55998
55999       SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
56000
56001 C...Double precision declaration.
56002       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56003       IMPLICIT INTEGER(I-N)
56004 C...Commonblock.
56005       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56006       SAVE /PYBINS/
56007 C...Local character variables.
56008       CHARACTER TITLE*(*), TITFX*60
56009
56010 C...Check that input is sensible. Find initial address in memory.
56011       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56012      &'(PYBOOK:) not allowed histogram number')
56013       IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
56014      &'(PYBOOK:) not allowed number of bins')
56015       IF(XL.GE.XU) CALL PYERRM(28,
56016      &'(PYBOOK:) x limits in wrong order')
56017       INDX(ID)=IHIST(4)
56018       IHIST(4)=IHIST(4)+28+NX
56019       IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
56020      &'(PYBOOK:) out of histogram space')
56021       IS=INDX(ID)
56022
56023 C...Store histogram size and reset contents.
56024       BIN(IS+1)=NX
56025       BIN(IS+2)=XL
56026       BIN(IS+3)=XU
56027       BIN(IS+4)=(XU-XL)/NX
56028       CALL PYNULL(ID)
56029
56030 C...Store title by conversion to integer to double precision.
56031       TITFX=TITLE//' '
56032       DO 100 IT=1,20
56033         BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
56034      &  256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
56035   100 CONTINUE
56036
56037       RETURN
56038       END
56039
56040 C*********************************************************************
56041
56042 C...PYFILL
56043 C...Fills entry in histogram.
56044
56045       SUBROUTINE PYFILL(ID,X,W)
56046
56047 C...Double precision declaration.
56048       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56049       IMPLICIT INTEGER(I-N)
56050 C...Commonblock.
56051       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56052       SAVE /PYBINS/
56053
56054 C...Find initial address in memory. Increase number of entries.
56055       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56056      &'(PYFILL:) not allowed histogram number')
56057       IS=INDX(ID)
56058       IF(IS.EQ.0) CALL PYERRM(28,
56059      &'(PYFILL:) filling unbooked histogram')
56060       BIN(IS+5)=BIN(IS+5)+1D0
56061
56062 C...Find bin in x, including under/overflow, and fill.
56063       IF(X.LT.BIN(IS+2)) THEN
56064         BIN(IS+6)=BIN(IS+6)+W
56065       ELSEIF(X.GE.BIN(IS+3)) THEN
56066         BIN(IS+8)=BIN(IS+8)+W
56067       ELSE
56068         BIN(IS+7)=BIN(IS+7)+W
56069         IX=(X-BIN(IS+2))/BIN(IS+4)
56070         IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
56071         BIN(IS+9+IX)=BIN(IS+9+IX)+W
56072       ENDIF
56073
56074       RETURN
56075       END
56076
56077 C*********************************************************************
56078
56079 C...PYFACT
56080 C...Multiplies histogram contents by factor.
56081
56082       SUBROUTINE PYFACT(ID,F)
56083
56084 C...Double precision declaration.
56085       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56086       IMPLICIT INTEGER(I-N)
56087 C...Commonblock.
56088       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56089       SAVE /PYBINS/
56090
56091 C...Find initial address in memory. Multiply all contents bins.
56092       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56093      &'(PYFACT:) not allowed histogram number')
56094       IS=INDX(ID)
56095       IF(IS.EQ.0) CALL PYERRM(28,
56096      &'(PYFACT:) scaling unbooked histogram')
56097       DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
56098         BIN(IX)=F*BIN(IX)
56099   100 CONTINUE
56100
56101       RETURN
56102       END
56103
56104 C*********************************************************************
56105
56106 C...PYOPER
56107 C...Performs operations between histograms.
56108
56109       SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
56110
56111 C...Double precision declaration.
56112       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56113       IMPLICIT INTEGER(I-N)
56114 C...Commonblock.
56115       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56116       SAVE /PYBINS/
56117 C...Character variable.
56118       CHARACTER OPER*(*)
56119
56120 C...Find initial addresses in memory, and histogram size.
56121       IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
56122      &'(PYFACT:) not allowed histogram number')
56123       IS1=INDX(ID1)
56124       IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
56125       IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
56126       NX=NINT(BIN(IS3+1))
56127       IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
56128
56129 C...Update info on number of histogram entries.
56130       IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
56131         BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
56132       ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
56133         BIN(IS3+5)=BIN(IS1+5)
56134       ENDIF
56135
56136 C...Operations on pair of histograms: addition, subtraction,
56137 C...multiplication, division.
56138       IF(OPER.EQ.'+') THEN
56139         DO 100 IX=6,8+NX
56140           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
56141   100   CONTINUE
56142       ELSEIF(OPER.EQ.'-') THEN
56143         DO 110 IX=6,8+NX
56144           BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
56145   110   CONTINUE
56146       ELSEIF(OPER.EQ.'*') THEN
56147         DO 120 IX=6,8+NX
56148           BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
56149   120   CONTINUE
56150       ELSEIF(OPER.EQ.'/') THEN
56151         DO 130 IX=6,8+NX
56152           FA2=F2*BIN(IS2+IX)
56153           IF(ABS(FA2).LE.1D-20) THEN
56154             BIN(IS3+IX)=0D0
56155           ELSE
56156             BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
56157           ENDIF
56158   130   CONTINUE
56159
56160 C...Operations on single histogram: multiplication+addition,
56161 C...square root+addition, logarithm+addition.
56162       ELSEIF(OPER.EQ.'A') THEN
56163         DO 140 IX=6,8+NX
56164           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
56165   140   CONTINUE
56166       ELSEIF(OPER.EQ.'S') THEN
56167         DO 150 IX=6,8+NX
56168           BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
56169   150   CONTINUE
56170       ELSEIF(OPER.EQ.'L') THEN
56171         ZMIN=1D20
56172         DO 160 IX=9,8+NX
56173           IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
56174      &    ZMIN=0.8D0*BIN(IS1+IX)
56175   160   CONTINUE
56176         DO 170 IX=6,8+NX
56177           BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
56178   170   CONTINUE
56179
56180 C...Operation on two or three histograms: average and
56181 C...standard deviation.
56182       ELSEIF(OPER.EQ.'M') THEN
56183         DO 180 IX=6,8+NX
56184           IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56185             BIN(IS2+IX)=0D0
56186           ELSE
56187             BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
56188           ENDIF
56189           IF(ID3.NE.0) THEN
56190             IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56191               BIN(IS3+IX)=0D0
56192             ELSE
56193               BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
56194      &        BIN(IS2+IX)**2))
56195             ENDIF
56196           ENDIF
56197           BIN(IS1+IX)=F1*BIN(IS1+IX)
56198   180   CONTINUE
56199       ENDIF
56200
56201       RETURN
56202       END
56203
56204 C*********************************************************************
56205
56206 C...PYHIST
56207 C...Prints and resets all histograms.
56208
56209       SUBROUTINE PYHIST
56210
56211 C...Double precision declaration.
56212       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56213       IMPLICIT INTEGER(I-N)
56214 C...Commonblock.
56215       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56216       SAVE /PYBINS/
56217
56218 C...Loop over histograms, print and reset used ones.
56219       DO 100 ID=1,IHIST(1)
56220         IS=INDX(ID)
56221         IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
56222           CALL PYPLOT(ID)
56223           CALL PYNULL(ID)
56224         ENDIF
56225   100 CONTINUE
56226
56227       RETURN
56228       END
56229
56230 C*********************************************************************
56231
56232 C...PYPLOT
56233 C...Prints a histogram (but does not reset it).
56234
56235       SUBROUTINE PYPLOT(ID)
56236
56237 C...Double precision declaration.
56238       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56239       IMPLICIT INTEGER(I-N)
56240 C...Commonblocks.
56241       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56242       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56243       SAVE /PYDAT1/,/PYBINS/
56244 C...Local arrays and character variables.
56245       DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
56246       CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
56247
56248 C...Steps in histogram scale. Character sequence.
56249       DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
56250       DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
56251
56252 C...Find initial address in memory; skip if empty histogram.
56253       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56254       IS=INDX(ID)
56255       IF(IS.EQ.0) RETURN
56256       IF(NINT(BIN(IS+5)).LE.0) THEN
56257         WRITE(MSTU(11),5000) ID
56258         RETURN
56259       ENDIF
56260
56261 C...Number of histogram lines and x bins.
56262       LIN=IHIST(3)-18
56263       NX=NINT(BIN(IS+1))
56264
56265 C...Extract title by conversion from double precision via integer.
56266       DO 100 IT=1,20
56267         IEQ=NINT(BIN(IS+8+NX+IT))
56268         TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
56269      &  //CHAR(MOD(IEQ,256))
56270   100 CONTINUE
56271
56272 C...Find time; print title.
56273       CALL PYTIME(IDATI)
56274       IF(IDATI(1).GT.0) THEN
56275         WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
56276       ELSE
56277         WRITE(MSTU(11),5200) ID, TITLE
56278       ENDIF
56279
56280 C...Find minimum and maximum bin content.
56281       YMIN=BIN(IS+9)
56282       YMAX=BIN(IS+9)
56283       DO 110 IX=IS+10,IS+8+NX
56284         IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
56285         IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
56286   110 CONTINUE
56287
56288 C...Determine scale and step size for y axis.
56289       IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
56290         IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
56291         IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
56292         IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
56293         IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
56294         IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
56295         DELY=DYAC(1)
56296         DO 120 IDEL=1,9
56297           IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
56298   120   CONTINUE
56299         DY=DELY*10D0**IPOT
56300
56301 C...Convert bin contents to integer form; fractional fill in top row.
56302         DO 130 IX=1,NX
56303           CTA=ABS(BIN(IS+8+IX))/DY
56304           IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
56305           IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
56306   130   CONTINUE
56307         IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
56308         IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
56309
56310 C...Print histogram row by row.
56311         DO 150 IR=IRMA,IRMI,-1
56312           IF(IR.EQ.0) GOTO 150
56313           OUT=' '
56314           DO 140 IX=1,NX
56315             IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
56316             IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
56317   140     CONTINUE
56318           WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
56319   150   CONTINUE
56320
56321 C...Print sign and value of bin contents.
56322         IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
56323         OUT=' '
56324         DO 160 IX=1,NX
56325           IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
56326           IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
56327   160   CONTINUE
56328         WRITE(MSTU(11),5400) OUT
56329         DO 180 IR=4,1,-1
56330           DO 170 IX=1,NX
56331             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56332   170     CONTINUE
56333           WRITE(MSTU(11),5500) IPOT+IR-4, OUT
56334   180   CONTINUE
56335
56336 C...Print sign and value of lower bin edge.
56337         IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
56338      &  10.0001D0)-10
56339         OUT=' '
56340         DO 190 IX=1,NX
56341           IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
56342      &    OUT(IX:IX)=CHA(11)
56343           IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
56344   190   CONTINUE
56345         WRITE(MSTU(11),5600) OUT
56346         DO 210 IR=3,1,-1
56347           DO 200 IX=1,NX
56348             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56349   200     CONTINUE
56350           WRITE(MSTU(11),5500) IPOT+IR-3, OUT
56351   210   CONTINUE
56352       ENDIF
56353
56354 C...Calculate and print statistics.
56355       CSUM=0D0
56356       CXSUM=0D0
56357       CXXSUM=0D0
56358       DO 220 IX=1,NX
56359         CTA=ABS(BIN(IS+8+IX))
56360         X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
56361         CSUM=CSUM+CTA
56362         CXSUM=CXSUM+CTA*X
56363         CXXSUM=CXXSUM+CTA*X**2
56364   220 CONTINUE
56365       XMEAN=CXSUM/MAX(CSUM,1D-20)
56366       XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
56367       WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
56368      &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
56369
56370 C...Formats for output.
56371  5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
56372  5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
56373      &I2,':',I2/)
56374  5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
56375  5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
56376  5400 FORMAT(/8X,'Contents',3X,A100)
56377  5500 FORMAT(9X,'*10**',I2,3X,A100)
56378  5600 FORMAT(/8X,'Low edge',3X,A100)
56379  5700 FORMAT(/5X,'Entries  =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
56380      &,D12.4,6X,'Low edge  =',D12.4/5X,'All chan =',D12.4,6X,
56381      &'Rms  =',D12.4,6X,'Overflow  =',D12.4,6X,'High edge =',D12.4)
56382
56383       RETURN
56384       END
56385
56386 C*********************************************************************
56387
56388 C...PYNULL
56389 C...Resets bin contents of a histogram.
56390
56391       SUBROUTINE PYNULL(ID)
56392
56393 C...Double precision declaration.
56394       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56395       IMPLICIT INTEGER(I-N)
56396 C...Commonblock.
56397       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56398       SAVE /PYBINS/
56399
56400       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56401       IS=INDX(ID)
56402       IF(IS.EQ.0) RETURN
56403       DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
56404         BIN(IX)=0D0
56405   100 CONTINUE
56406
56407       RETURN
56408       END
56409
56410 C*********************************************************************
56411
56412 C...PYDUMP
56413 C...Dumps histogram contents on file for reading by other program.
56414 C...Can also read back own dump.
56415
56416       SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
56417
56418 C...Double precision declaration.
56419       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56420       IMPLICIT INTEGER(I-N)
56421 C...Commonblock.
56422       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56423       SAVE /PYBINS/
56424 C...Local arrays and character variables.
56425       DIMENSION IHI(*),ISS(100),VAL(5)
56426       CHARACTER TITLE*60,FORMAT*13
56427
56428 C...Dump all histograms that have been booked,
56429 C...including titles and ranges, one after the other.
56430       IF(MDUMP.EQ.1) THEN
56431
56432 C...Loop over histograms and find which are wanted and booked.
56433         IF(NHI.LE.0) THEN
56434           NW=IHIST(1)
56435         ELSE
56436           NW=NHI
56437         ENDIF
56438         DO 130 IW=1,NW
56439           IF(NHI.EQ.0) THEN
56440             ID=IW
56441           ELSE
56442             ID=IHI(IW)
56443           ENDIF
56444           IS=INDX(ID)
56445           IF(IS.NE.0) THEN
56446
56447 C...Write title, histogram size, filling statistics.
56448             NX=NINT(BIN(IS+1))
56449             DO 100 IT=1,20
56450               IEQ=NINT(BIN(IS+8+NX+IT))
56451               TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
56452      &        CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
56453   100       CONTINUE
56454             WRITE(LFN,5100) ID,TITLE
56455             WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
56456             WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
56457      &      BIN(IS+8)
56458
56459
56460 C...Write histogram contents, in groups of five.
56461             DO 120 IXG=1,(NX+4)/5
56462               DO 110 IXV=1,5
56463                 IX=5*IXG+IXV-5
56464                 IF(IX.LE.NX) THEN
56465                   VAL(IXV)=BIN(IS+8+IX)
56466                 ELSE
56467                   VAL(IXV)=0D0
56468                 ENDIF
56469   110         CONTINUE
56470               WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
56471   120       CONTINUE
56472
56473 C...Go to next histogram; finish.
56474           ELSEIF(NHI.GT.0) THEN
56475             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56476           ENDIF
56477   130   CONTINUE
56478
56479 C...Read back in histograms dumped MDUMP=1.
56480       ELSEIF(MDUMP.EQ.2) THEN
56481
56482 C...Read histogram number, title and range, and book.
56483   140   READ(LFN,5100,END=170) ID,TITLE
56484         READ(LFN,5200) NX,XL,XU
56485         CALL PYBOOK(ID,TITLE,NX,XL,XU)
56486         IS=INDX(ID)
56487
56488 C...Read filling statistics.
56489         READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
56490         BIN(IS+5)=DBLE(NENTRY)
56491
56492 C...Read histogram contents, in groups of five.
56493         DO 160 IXG=1,(NX+4)/5
56494           READ(LFN,5400) (VAL(IXV),IXV=1,5)
56495           DO 150 IXV=1,5
56496             IX=5*IXG+IXV-5
56497             IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
56498   150     CONTINUE
56499   160   CONTINUE
56500
56501 C...Go to next histogram; finish.
56502         GOTO 140
56503   170   CONTINUE
56504
56505 C...Write histogram contents in column format,
56506 C...convenient e.g. for GNUPLOT input.
56507       ELSEIF(MDUMP.EQ.3) THEN
56508
56509 C...Find addresses to wanted histograms.
56510         NSS=0
56511         IF(NHI.LE.0) THEN
56512           NW=IHIST(1)
56513         ELSE
56514           NW=NHI
56515         ENDIF
56516         DO 180 IW=1,NW
56517           IF(NHI.EQ.0) THEN
56518             ID=IW
56519           ELSE
56520             ID=IHI(IW)
56521           ENDIF
56522           IS=INDX(ID)
56523           IF(IS.NE.0.AND.NSS.LT.100) THEN
56524             NSS=NSS+1
56525             ISS(NSS)=IS
56526           ELSEIF(NSS.GE.100) THEN
56527             CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
56528           ELSEIF(NHI.GT.0) THEN
56529             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56530           ENDIF
56531   180   CONTINUE
56532
56533 C...Check that they have common number of x bins. Fix format.
56534         NX=NINT(BIN(ISS(1)+1))
56535         DO 190 IW=2,NSS
56536           IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
56537             CALL PYERRM(8,'(PYDUMP:) different number of bins')
56538             RETURN
56539           ENDIF
56540   190   CONTINUE
56541         FORMAT='(1P,000E12.4)'
56542         WRITE(FORMAT(5:7),'(I3)') NSS+1
56543
56544 C...Write histogram contents; first column x values.
56545         DO 200 IX=1,NX
56546           X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
56547           WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
56548   200   CONTINUE
56549
56550       ENDIF
56551
56552 C...Formats for output.
56553  5100 FORMAT(I5,5X,A60)
56554  5200 FORMAT(I5,1P,2D12.4)
56555  5300 FORMAT(I12,1P,3D12.4)
56556  5400 FORMAT(1P,5D12.4)
56557
56558       RETURN
56559       END
56560
56561 C*********************************************************************
56562
56563 C...PYKCUT
56564 C...Dummy routine, which the user can replace in order to make cuts on
56565 C...the kinematics on the parton level before the matrix elements are
56566 C...evaluated and the event is generated. The cross-section estimates
56567 C...will automatically take these cuts into account, so the given
56568 C...values are for the allowed phase space region only. MCUT=0 means
56569 C...that the event has passed the cuts, MCUT=1 that it has failed.
56570
56571       SUBROUTINE PYKCUT(MCUT)
56572
56573 C...Double precision and integer declarations.
56574       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56575       IMPLICIT INTEGER(I-N)
56576       INTEGER PYK,PYCHGE,PYCOMP
56577 C...Commonblocks.
56578       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56579       COMMON/PYINT1/MINT(400),VINT(400)
56580       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56581       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56582
56583 C...Set default value (accepting event) for MCUT.
56584       MCUT=0
56585
56586 C...Read out subprocess number.
56587       ISUB=MINT(1)
56588       ISTSB=ISET(ISUB)
56589
56590 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56591       TAU=VINT(21)
56592       YST=VINT(22)
56593       CTH=0D0
56594       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56595       TAUP=0D0
56596       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56597
56598 C...Calculate x_1, x_2, x_F.
56599       IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
56600         X1=SQRT(TAU)*EXP(YST)
56601         X2=SQRT(TAU)*EXP(-YST)
56602       ELSE
56603         X1=SQRT(TAUP)*EXP(YST)
56604         X2=SQRT(TAUP)*EXP(-YST)
56605       ENDIF
56606       XF=X1-X2
56607
56608 C...Calculate shat, that, uhat, p_T^2.
56609       SHAT=TAU*VINT(2)
56610       SQM3=VINT(63)
56611       SQM4=VINT(64)
56612       RM3=SQM3/SHAT
56613       RM4=SQM4/SHAT
56614       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
56615       RPTS=4D0*VINT(71)**2/SHAT
56616       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
56617       RM34=2D0*RM3*RM4
56618       RSQM=1D0+RM34
56619       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
56620       THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
56621       UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
56622       PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
56623
56624 C...Decisions by user to be put here.
56625
56626 C...Stop program if this routine is ever called.
56627 C...You should not copy these lines to your own routine.
56628       WRITE(MSTU(11),5000)
56629       IF(PYR(0).LT.10D0) STOP
56630
56631 C...Format for error printout.
56632  5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
56633      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56634      &1X,'Execution stopped!')
56635
56636       RETURN
56637       END
56638
56639 C*********************************************************************
56640
56641 C...PYEVWT
56642 C...Dummy routine, which the user can replace in order to multiply the
56643 C...standard PYTHIA differential cross-section by a process- and
56644 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
56645 C...to generation of weighted events, with weight 1/WTXS, while for
56646 C...MSTP(142)=2 it corresponds to a modification of the underlying
56647 C...physics.
56648
56649       SUBROUTINE PYEVWT(WTXS)
56650
56651 C...Double precision and integer declarations.
56652       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56653       IMPLICIT INTEGER(I-N)
56654       INTEGER PYK,PYCHGE,PYCOMP
56655 C...Commonblocks.
56656       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56657       COMMON/PYINT1/MINT(400),VINT(400)
56658       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56659       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56660
56661 C...Set default weight for WTXS.
56662       WTXS=1D0
56663
56664 C...Read out subprocess number.
56665       ISUB=MINT(1)
56666       ISTSB=ISET(ISUB)
56667
56668 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56669       TAU=VINT(21)
56670       YST=VINT(22)
56671       CTH=0D0
56672       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56673       TAUP=0D0
56674       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56675
56676 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
56677       X1=VINT(41)
56678       X2=VINT(42)
56679       XF=X1-X2
56680       SHAT=VINT(44)
56681       THAT=VINT(45)
56682       UHAT=VINT(46)
56683       PT2=VINT(48)
56684
56685 C...Modifications by user to be put here.
56686
56687 C...Stop program if this routine is ever called.
56688 C...You should not copy these lines to your own routine.
56689       WRITE(MSTU(11),5000)
56690       IF(PYR(0).LT.10D0) STOP
56691
56692 C...Format for error printout.
56693  5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
56694      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56695      &1X,'Execution stopped!')
56696
56697       RETURN
56698       END
56699
56700 C*********************************************************************
56701
56702 C...UPINIT
56703 C...Dummy routine, to be replaced by a user implementing external
56704 C...processes. Is supposed to fill the HEPRUP commonblock with info
56705 C...on incoming beams and allowed processes.
56706
56707       SUBROUTINE UPINIT
56708
56709 C...Double precision and integer declarations.
56710       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56711       IMPLICIT INTEGER(I-N)
56712
56713 C...User process initialization commonblock.
56714       INTEGER MAXPUP
56715       PARAMETER (MAXPUP=100)
56716       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
56717       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
56718       COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
56719      &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
56720      &LPRUP(MAXPUP)
56721       SAVE /HEPRUP/
56722
56723       RETURN
56724       END
56725
56726 C*********************************************************************
56727
56728 C...UPEVNT
56729 C...Dummy routine, to be replaced by a user implementing external
56730 C...processes. Depending on cross section model chosen, it either has
56731 C...to generate a process of the type IDPRUP requested, or pick a type
56732 C...itself and generate this event. The event is to be stored in the
56733 C...HEPEUP commonblock, including (often) an event weight.
56734
56735       SUBROUTINE UPEVNT
56736
56737 C...Double precision and integer declarations.
56738       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56739       IMPLICIT INTEGER(I-N)
56740
56741 C...User process event common block.
56742       INTEGER MAXNUP
56743       PARAMETER (MAXNUP=500)
56744       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
56745       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
56746       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
56747      &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
56748      &VTIMUP(MAXNUP),SPINUP(MAXNUP)
56749       SAVE /HEPEUP/
56750
56751       RETURN
56752       END
56753
56754 C*********************************************************************
56755
56756 C...PYTAUD
56757 C...Dummy routine, to be replaced by user, to handle the decay of a
56758 C...polarized tau lepton.
56759 C...Input:
56760 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
56761 C...IORIG is the position where the mother of the tau is stored;
56762 C...     is 0 when the mother is not stored.
56763 C...KFORIG is the flavour of the mother of the tau;
56764 C...     is 0 when the mother is not known.
56765 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
56766 C...     e.g. in B hadron semileptonic decays the W  propagator
56767 C...     is not explicitly stored but the W code is still unambiguous.
56768 C...Output:
56769 C...NDECAY is the number of decay products in the current tau decay.
56770 C...These decay products should be added to the /PYJETS/ common block,
56771 C...in positions N+1 through N+NDECAY. For each product I you must
56772 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
56773 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
56774
56775       SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
56776
56777 C...Double precision and integer declarations.
56778       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56779       IMPLICIT INTEGER(I-N)
56780       INTEGER PYK,PYCHGE,PYCOMP
56781 C...Commonblocks.
56782       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56783       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56784       SAVE /PYJETS/,/PYDAT1/
56785
56786 C...Stop program if this routine is ever called.
56787 C...You should not copy these lines to your own routine.
56788       NDECAY=ITAU+IORIG+KFORIG
56789       WRITE(MSTU(11),5000)
56790       IF(PYR(0).LT.10D0) STOP
56791
56792 C...Format for error printout.
56793  5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
56794      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56795      &1X,'Execution stopped!')
56796
56797       RETURN
56798       END
56799
56800 C*********************************************************************
56801
56802 C...PYTIME
56803 C...Finds current date and time.
56804 C...Since this task is not standardized in Fortran 77, the routine
56805 C...is dummy, to be replaced by the user. Examples are given for
56806 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
56807 C...you do not have access to suitable routines.
56808
56809       SUBROUTINE PYTIME(IDATI)
56810
56811 C...Double precision and integer declarations.
56812       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56813       IMPLICIT INTEGER(I-N)
56814       INTEGER PYK,PYCHGE,PYCOMP
56815       CHARACTER*8 ATIME
56816 C...Local array.
56817       INTEGER IDATI(6),IDTEMP(3)
56818
56819 C...Example 0: if you do not have suitable routines.
56820       DO 100 J=1,6
56821       IDATI(J)=0
56822   100 CONTINUE
56823
56824 C...Example 1: Fortran 90 routine.
56825 C      INTEGER IVAL(8)
56826 C      CALL DATE_AND_TIME(VALUES=IVAL)
56827 C      IDATI(1)=IVAL(1)
56828 C      IDATI(2)=IVAL(2)
56829 C      IDATI(3)=IVAL(3)
56830 C      IDATI(4)=IVAL(5)
56831 C      IDATI(5)=IVAL(6)
56832 C      IDATI(6)=IVAL(7)
56833
56834 C...Example 2: DEC Fortran 77. AIX.
56835 C      CALL IDATE(IMON,IDAY,IYEAR)
56836 C      IDATI(1)=IYEAR
56837 C      IDATI(2)=IMON
56838 C      IDATI(3)=IDAY
56839 C      CALL ITIME(IHOUR,IMIN,ISEC)
56840 C      IDATI(4)=IHOUR
56841 C      IDATI(5)=IMIN
56842 C      IDATI(6)=ISEC
56843
56844 C...Example 3: DEC Fortran, IRIX, IRIX64.
56845 C      CALL IDATE(IMON,IDAY,IYEAR)
56846 C      IDATI(1)=IYEAR
56847 C      IDATI(2)=IMON
56848 C      IDATI(3)=IDAY
56849 C      CALL TIME(ATIME)
56850 C      IHOUR=0
56851 C      IMIN=0
56852 C      ISEC=0
56853 C      READ(ATIME(1:2),'(I2)') IHOUR
56854 C      READ(ATIME(4:5),'(I2)') IMIN
56855 C      READ(ATIME(7:8),'(I2)') ISEC
56856 C      IDATI(4)=IHOUR
56857 C      IDATI(5)=IMIN
56858 C      IDATI(6)=ISEC
56859
56860 C...Example 4: GNU LINUX libU77, SunOS.
56861 c      CALL IDATE(IDTEMP)
56862 c      IDATI(1)=IDTEMP(3)
56863 c      IDATI(2)=IDTEMP(2)
56864 c      IDATI(3)=IDTEMP(1)
56865 c      CALL ITIME(IDTEMP)
56866 c      IDATI(4)=IDTEMP(1)
56867 c      IDATI(5)=IDTEMP(2)
56868 c      IDATI(6)=IDTEMP(3)
56869
56870 C...Common code to ensure right century.
56871       IDATI(1)=2000+MOD(IDATI(1),100)
56872
56873       RETURN
56874       END